perm filename ILOAD.MAC[LSP,SYS] blob
sn#046094 filedate 1973-06-05 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00117 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00011 00002 SUBTTL RP GRUEN/NGP/WFW/DMN V.052 7-SEP-70
C00014 00003 DEFAULT ASSEMBLY SWITCH SETTINGS ++ lisp switch here ++
C00017 00004 ACCUMULATOR ASSIGNMENTS
C00019 00005 FLAGS F(0 - 17)
C00022 00006
C00024 00007 IFE K,< TITLE LOADER - LOADS MACRO AND FORTRAN FOUR>
C00026 00008 CCL INITIALIZATION
C00029 00009 RPGS3: MOVEI CTLBUF
C00031 00010 NORMAL INITIALIZATION
C00036 00011 MOVE W,[XWD LINKTB,LINKTB+1]
C00037 00012 IFN RPGSW,<JRST LD2Q>
C00042 00013 MOVE T,@CTLIN+1 AND CHECK FOR LINE #
C00043 00014 TRNE T,1
C00044 00015 CHARACTER HANDLING
C00047 00016 OUTPUT SPECIFICATION DELIMITER <=> OR <LEFT ARROW>
C00050 00017 RIGHT SQUARE BRACKET (PROJ-PROG NUMBERS)
C00053 00018
C00056 00019 TERMINATION
C00058 00020 IFE L,< NONE OF THIS NEEDED FOR LISP
C00061 00021 PRINT FINAL MESSAGE
C00066 00022 SET UP JOBDAT
C00071 00023 BLT SYMBOL TABLE INTO HIGH SEGMENT
C00073 00024 NOBLT: HRRZ Q,HILOW GET HIGHEST LOC LOADED
C00075 00025 WRITE CHAIN FILES
C00078 00026 SPECIAL CHAINB
C00082 00027 SMTBFX: TLNE N,PPCSW IF NOT CUTTING BACK SYMBOL TABLE
C00087 00028 EXPAND CORE
C00089 00029
C00090 00030 SWITCH HANDLING
C00091 00031 DISPATCH TABLE FOR SWITCHES
C00095 00032 PAIRED SWITCHES ( +,-)
C00097 00033 IFN REENT,<
C00099 00034 SWITCH MODE NUMERIC ARGUMENT
C00101 00035 ATTEMPT TO CHAIN WITH SPECIFIED HALF OF JOBCHN = 0
C00102 00036 CHARACTER CLASSIFICATION TABLE DESCRIPTION:
C00104 00037 BYTE POINTERS TO CHARACTER CLASSIFICATION TABLE
C00106 00038 INITIALIZE LOADING OF A FILE
C00109 00039 LIBRARY SEARCH CONTROL AND LOADER CONTROL
C00112 00040 LIB CONTROLS THE LIBRARY SEARCH OF ONE FILE
C00114 00041 IFN SAILSW,<
C00117 00042 LDDT LOADS <SYS:DDT.REL> AND SETS SYMSW
C00120 00043 EOF TERMINATES LOADING OF A FILE
C00122 00044 LOAD SUBROUTINE
C00125 00045 LOAD PROGRAMS AND DATA (BLOCK TYPE 1)
C00128 00046 LOAD SYMBOLS (BLOCK TYPE 2)
C00130 00047 LOCAL SYMBOL
C00131 00048 GLOBAL DEFINITION MATCHES REQUEST
C00134 00049
C00137 00050 FIXWL: HRLZ T,W UPDATE VALUE OF LEFT HALF
C00139 00051 PATCH VALUES INTO CHAINED REQUEST
C00141 00052 HIGH-SEGMENT (BLOCK TYPE 3)
C00144 00053 SETSEG: TRZ F,NOHI!SEGFL ALLOW HI-SEG
C00145 00054 HIGHEST RELOCATABLE POINT (BLOCK TYPE 5)
C00150 00055 HRRZ C,R SET UP C AGAIN
C00151 00056 EXPAND HIGH SEGMENT
C00153 00057 PROGRAM NAME (BLOCK TYPE 6)
C00156 00058 COMPILER TYPE - DO SPECIAL FUNCTION FOR IT
C00157 00059 STARTING ADDRESS (BLOCK TYPE 7)
C00158 00060 ONE PASS LOCAL DEFINITION (BLOCK TYPE 10)
C00160 00061 LVAR FIX-UP (BLOCK TYPE 13)
C00163 00062 FAIL LOADER
C00168 00063 (NOTE THIS IS JUST A STANDARD GLOBAL REQUEST)
C00169 00064 SATISFIED)
C00170 00065 THE SYMBOL SHOULD BE STORED
C00171 00066 IFN FAILSW,<
C00174 00067 HANDLE OPERANDS. THIS GETS COMPLICATED BECAUSE OF THE PRESENCE OF
C00176 00068 HAVE ENOUGH OPERANDS FOR THE CURRENT OPERATOR
C00179 00069 FINALLY WE GET TO STORE THIS MESS
C00181 00070 ALSTR1: IFN L,<CAMGE V,RINITL
C00183 00071 POLSAT: PUSH P,C SAVE SYMBOL
C00185 00072 PSAT2: HRL C,HDSAV GET FIXUP NUMBER
C00188 00073 STRSAT: MOVE W,C GET VALUE TO STORE IN W
C00189 00074 LIBRARY INDEX (BLOCK TYPE 14)
C00192 00075 INDEX4: ADDM T,ABUF1
C00196 00076 THSBLK: SUB A,LSTBLK GET WORD DIFFERENCE
C00198 00077 ALGOL OWN BLOCK (TYPE 15)
C00201 00078 SAIL BLOCK TYPE 15
C00203 00079 SYMBOL TABLE SEARCH SUBROUTINES
C00205 00080 RELOCATION AND BLOCK INPUT
C00207 00081 PRINT STORAGE MAP SUBROUTINE
C00212 00082 PRMP1A: PUSHJ P,TAB
C00216 00083 LIST UNDEFINED AND MULTIPLY DEFINED GLOBALS
C00218 00084 ENTER FILE ON AUXILIARY OUTPUT DEVICE
C00220 00085 PRINT SUBROUTINES
C00221 00086
C00222 00087 ACCUMULATORS USED: Q,T,D
C00224 00088 SYMBOL PRINT - RADIX 50
C00226 00089
C00227 00090 ERROR MESSAGE PRINT SUBROUTINE
C00229 00091 ERRPT8: TLO F,FCONSW INSURE TTY OUTPUT
C00230 00092 INPUT - OUTPUT INTERFACE
C00232 00093 IMPURE CODE
C00233 00094 DATA STORAGE
C00235 00095 PT1: BLOCK 1
C00237 00096 BUFFER HEADERS AND HEADER HEADERS
C00239 00097 FORTRAN DATA STORAGE
C00241 00098 REMAP UUO
C00243 00099 LISP LOADER
C00244 00100 FORTRAN FOUR LOADER
C00246 00101 PROCESS TABLE ENTRIES
C00248 00102 STORE WORD AND SET BIT TABLE
C00251 00103 PROCESS END CODE WORD
C00256 00104
C00258 00105 BEGIN HERE PASS2 TEXT PROCESSING
C00260 00106
C00262 00107 ROUTINES TO PROCESS POINTERS
C00264 00108 NCO: PUSHJ P,SWAPSY
C00266 00109
C00267 00110 END OF PASS2
C00270 00111 FBLKD: TLOE N,BLKD1 IS THIS FIRST BLOCK DATA?
C00274 00112 CONPOL: ADD T,ITC CONSTANT BASE
C00276 00113 DODONE: POP P,-1(P) BACK UP ADDRESS
C00278 00114 DREAD: TLNE N,RCF NEW REPEAT COUNT NEEDED
C00280 00115 ROUTINE TO SKIP FORTRAN OUTPUT
C00283 00116 LISP LOADER
C00284 00117
C00285 ENDMK
C⊗;
SUBTTL RP GRUEN/NGP/WFW/DMN V.052 7-SEP-70
; RFS 11-30-70
; TURNED ON FAILSW,SAILSW FOR NIH USAGE.
; DCS 1-24-71
; ADDITIONS FOR SAIL (SHARED EXECS, UPDATED STANSW)
; REG 7-17-71
; TURN ON REENT FEATURES
VLOADER==52
VPATCH==0 ;DEC PATCH LEVEL
VCUSTOM==<SIXBIT / SG1/> ;NON-DEC PATCH LEVEL
;SAISEG VERSION 1
LOC <JOBVER==137>
XWD VCUSTOM,VLOADER+1000*VPATCH
RELOC
COMMENT * ASSEMBLY FEATURE SWITCHES (ACTION WHEN NON-ZERO)
SWITCHES ON (NON-ZERO) IN DEC VERSION
SEG2SW GIVES TWO SEGMENT CODE (IF MACRO ALLOWS IT)
PURESW GIVES PURE CODE (VARIABLES IN LOW SEG)
REENT GIVES REENTRANT CAPABILITY PDP-10
(REENT=0 FOR PDP-10/30 OR PDP-6 OR EARLY PDP-10)
RPGSW INCLUDE CCL FEATURE
TEMP INCLUDE TMPCOR FEATURE
DMNSW SYMBOL TABLE WILL BE MOVED DOWN FROM TOP OF CORE
KUTSW GIVES CORE CUTBACK ON /K
EXPAND FOR AUTOMATIC CORE EXPANSION
PP ALLOW PROJ-PROG #
DIDAL GIVES DIRECT ACCESS LIBRARY SEARCH MODE
ALGSW WILL LOAD ALGOL OWN BLOCK (TYPE 15)
SWITCHES OFF (ZERO) IN DEC VERSION
K GIVES 1KLOADER - NO F4
L FOR LISP LOADER
SPMON GIVES SPMON LOADER (MONITOR LOADER)
TEN30 FOR 10/30 LOADER
STANSW GIVES STANFORD FEATURES
LNSSW GIVES LNS VERSION
FAILSW INCLUDE PROVISIONS FOR SPECIAL FAIL FIXUPS.
LDAC MEANS LOAD CODE INTO ACS
(LDAC DOES NOT WORK WITH KUTSW=1.CORE UUO CLEARS JOBBLT)
WFWSW GIVES BLOCK TYPE 13 (VARIABLS INTO LOW SEG)
SYMARG ACCEPT SYMBOLIC (GLOBAL) ARGUMENTS FOR SWITCHES
SPCHN WILL DO SPECIAL OVERLAYING
SAILSW GIVES BLOCK TYPE 15 (FORCE LOAD OF REL FILES)
AND 16 (FORCE SEARCH OF LIBRARIES) FOR SAIL
*
COMMENT/
AT STANFORD WE USE
STANSW, SAILSW, FAILSW, AND REENT ALL ON
ALGSW, PURESW AND SEG2SW ALL OFF
/
STANSW==1
SAILSW==1
FAILSW==1
REENT==1
ALGSW==0
PURESW==0
SEG2SW==0
SUBTTL DEFAULT ASSEMBLY SWITCH SETTINGS ++ lisp switch here ++
IFNDEF SPMON,<SPMON=0>
IFN SPMON,< TEN30==1
K==1>
L==1 ;this off makes regular Stanf. loader
IFNDEF L,<L=0>
IFNDEF TEN30,<TEN30=0>
IFN TEN30!L,< RPGSW=0
PP=0
IFNDEF DMNSW,< DMNSW=0>
DIDAL==1
IFNDEF DIDAL,< DIDAL=0>
ALGSW=0
PURESW=0
REENT=0
LDAC=0
KUTSW=0
SEG2SW=0
NAMESW=0>
IFN TEN30,< EXPAND=0>
IFNDEF K,<K=0>
STANSW==1
IFNDEF STANSW,<STANSW=0>
IFN STANSW,<
FAILSW=1
TEMP==0
REENT==1>
IFNDEF LNSSW,<LNSSW=0>
IFN LNSSW,<LDAC=1
PP=0>
FAILSW==1
IFNDEF FAILSW,<FAILSW=0>
IFNDEF RPGSW,<RPGSW==1>
IFN RPGSW,<PP==1> ;REQUIRE DISK FOR CCL
IFE RPGSW,<TEMP=0>
IFNDEF PP,<PP==1>
IFN L,<PP==1>
IFNDEF TEMP,<TEMP==1>
IFNDEF NAMESW,<NAMESW==1>
IFNDEF LDAC,<LDAC=0>
IFN LDAC,<KUTSW=0>
IFNDEF KUTSW,<KUTSW==1>
IFNDEF EXPAND,< IFN K,<EXPAND==0>
IFE K,<EXPAND==1>>
IFNDEF DMNSW,<DMNSW==1>
IFN DMNSW!LDAC,<IFNDEF SYMPAT,<SYMPAT==20>
IFN LDAC,<IFG 20-SYMPAT,<SYMPAT==20>>>
IFNDEF REENT,<REENT==1>
IFE REENT,<PURESW=0
SEG2SW=0>
IFG STANSW,<SEG2SW==0
PURESW==0>
IFDEF TWOSEG,<IFNDEF SEG2SW,<SEG2SW==1>>
IFNDEF SEG2SW,<SEG2SW==0>
IFN SEG2SW,<PURESW==1>
IFNDEF PURESW,<PURESW==1>
IFNDEF WFWSW,<WFWSW==0>
IFN K,<SYMARG=0
SPCHN=0>
IFNDEF SYMARG,<SYMARG==0>
IFNDEF SPCHN,<SPCHN==0>
IFNDEF DIDAL,<DIDAL==1>
IFNDEF ALGSW,<ALGSW==0>
SAILSW==1
IFNDEF SAILSW,<SAILSW==0>
SUBTTL ACCUMULATOR ASSIGNMENTS
F=0 ;FLAGS IN BOTH HALVES OF F
N=1 ;FLAGS IN LH, PROGRAM NAME POINTER IN RH
X=2 ;LOADER OFFSET
H=3 ;HIGHEST LOC LOADED
S=4 ;UNDEFINED POINTER
R=5 ;RELOCATION CONSTANT
B=6 ;SYMBOL TABLE POINTER
D=7
T=10
V=T+1
W=12 ;VALUE
C=W+1 ;SYMBOL
E=C+1 ;DATA WORD COUNTER
Q=15 ;RELOCATION BITS
A=Q+1 ;SYMBOL SEARCH POINTER
P=17 ;PUSHDOWN POINTER
;MONITOR LOCATIONS IN THE USER AREA
JOBDA==140
JOBHDA==10
EXTERN JOBDDT,JOBFF,JOBSA,JOBREL,JOBSYM,JOBUSY,JOB41
IFN REENT,< EXTERN JOBHRL,JOBCOR>
IFE K,<EXTERN JOBCHN ;RH = PROG BREAK OF FIRST BLOCK DATA
;LH = PROG BREAK OF FIRST F4 PROG>
IFN RPGSW,< EXTERN JOBERR>
IFN LDAC,< EXTERN JOBBLT>
IFN FAILSW,< EXTERN JOBAPR>
NEGOFF==400 ;NEGATIVE OFFSET OF HIGH SEGMENT
IFN FAILSW,<;LENGTH OF PUSHDOWN LIST FOR POLISH FIXUPS
PPDL==60>
;FLAGS F(0 - 17)
CSW==1 ;ON - COLON SEEN
ESW==2 ;ON - EXPLICIT EXTENSION IDENT.
SKIPSW==4 ;ON - DO NOT LOAD THIS PROGRAM
FSW==10 ;ON - SCAN FORCED TO COMPLETION
FCONSW==20 ;ON - FORCE CONSOLE OUTPUT
IFN REENT,<HIPROG==40 ;LOADING HI PROGRAM, SET BY HISEG. CLEARED BY EOF>
ASW==100 ;ON - LEFT ARROW ILLEGAL
FULLSW==200 ;ON - STORAGE EXCEEDED
SLIBSW==400 ;ON - LIB SEARCH IN THIS PROG
RMSMSW==1000 ;REMEMBER IF LOADING WITH SYMBOLS DURING LIB SEARCH
REWSW==2000 ;ON - REWIND AFTER INIT
LIBSW==4000 ;ON - LIBRARY SEARCH MODE
NAMSSW==10000 ;NAME BLOCK HAS BEEN SEEN FOR THIS PROG
ISW==20000 ;ON - DO NOT PERFORM INIT
SYMSW==40000 ;ON - LOAD LOCAL SYMBOLS
DSW==100000 ;ON - CHAR IN IDENTIFIER
NSW==200000 ;ON - SUPPRESS LIBRARY SEARCH
SSW==400000 ;ON - SWITCH MODE
;FLAGS N(0 - 17)
ALLFLG==1 ;ON - LIST ALL GLOBALS
ISAFLG==2 ;ON - IGNORE STARTING ADDRESSES
COMFLG==4 ;ON - SIZE OF COMMON SET
IFE K,< F4SW==10 ;F4 IN PROGRESS
RCF==20 ;READ DATA COUNT
SYDAT==40; SYMBOL IN DATA>
SLASH==100 ;SLASH SEEN
IFE K,< BLKD1==200 ;ON- FIRST BLOCK DATA SEEN
PGM1==400 ;ON FIRST F4 PROG SEEN
DZER==1000 ;ON - ZERO SECOND DATA WORD>
EXEQSW==2000 ;IMMEDIATE EXECUTION
DDSW==4000 ;GO TO DDT
IFN RPGSW,<RPGF==10000 ;IN RPG MODE>
AUXSWI==20000 ;ON - AUX. DEVICE INITIALIZED
AUXSWE==40000 ;ON - AUX. DEVICE ENTERED
IFN PP,<PPSW==100000 ;ON - READING PROJ-PROG #>
IFN PP!SPCHN,<PPCSW==200000 ;ON - READING PROJ #>
IFN FAILSW,<HSW==400000 ;USED IN BLOCK 11 POLISH FIXUPS>
;MORE FLAGS IN F (18-35)
IFN REENT,<
SEENHI==1 ;HAVE SEEN HI STUFF
NOHI==2 ;LOAD AS NON-REENTRANT>
IFN RPGSW,<NOTTTY==4 ;DEV "TTY" IS NOT A TTY>
NOHI6==10 ;PDP-6 TYPE SYSTEM
IFN DMNSW,<HISYM==20 ;BLT SYMBOLS INTO HIGH SEGMENT>
SEGFL==40 ;LOAD INTO HI-SEG>
IFN DIDAL,<XFLG==100 ;INDEX IN CORE (BLOCK TYPE 14)
LSTLOD==200 ;LAST PROG WAS LOADED
DTAFLG==400 ;LIBRARY DEVICE IS A DTA (NEEDED FOR INDEXING)>
IFN DMNSW,<DMNFLG==1000> ;SYMBOL TABLE TO BE MOVED DOWN
IFN REENT,<VFLG==2000 ;DO LIB SEARCH OF IMP40.REL BEFORE LIB40>
IFN SYMARG,<ARGFL==4000 ;TREAT $%. AS RADIX-50 CHAR.>
TWOFL==10000 ;TWO SEGMENTS IN THIS BINARY FILE
LOCAFL==20000 ;PRINT LOCAL SYMBOLS IN MAP
TTYFL==40000 ;AUX. DEV. IS TTY
IFE K,<F4FL==400000 ;FORTRAN SEEN>
COBFL==200000 ;COBOL SEEN
IFN ALGSW,<ALGFL==100000 ;ALGOL SEEN>
DEFINE ERROR (X,Y)<
JSP A,ERRPT'X
SIXBIT Y>
IFE K,< TITLE LOADER - LOADS MACRO AND FORTRAN FOUR>
IFN K,< TITLE 1KLOAD - LOADS MACRO>
IFN PURESW,<
IFE SEG2SW,<HISEG>
IFN SEG2SW,<TWOSEGMENTS
RELOC 400000>>
IFN SPCHN,<
DSKBLK==200 ;LENGTH OF DISK BLOCKS
VECLEN==↑D25 ;LENGTH OF VECTOR TABLE FOR OVERLAYS>
IFN SAILSW,<
RELLEN==↑D20 ;#NUMBER OF REL FILES OR LIBRARIES (MUST BE SAME)>
;CALLI DEFINITIONS
OPDEF RESET [CALLI 0]
OPDEF SETDDT [CALLI 2]
OPDEF DDTOUT [CALLI 3]
OPDEF DEVCHR [CALLI 4]
OPDEF CORE [CALLI 11]
OPDEF EXIT [CALLI 12]
OPDEF UTPCLR [CALLI 13]
OPDEF DATE [CALLI 14]
OPDEF MSTIME [CALLI 23]
OPDEF PJOB [CALLI 30]
OPDEF SETUWP [CALLI 36]
OPDEF REMAP [CALLI 37]
OPDEF GETSEG [CALLI 40]
IFE STANSW,<
OPDEF SETNAM [CALLI 43]
>
IFN STANSW,<
OPDEF SETNAM [CALLI 400002]
>
OPDEF TMPCOR [CALLI 44]
MLON
IFDEF SALL,< SALL>
SUBTTL CCL INITIALIZATION
IFN RPGSW,<
BEG: JRST LD ;NORMAL INITIALIZATION
RPGSET: RESET ;RESET UUO.
IFN TEMP,<MOVEI F,CTLBUF-1 ;USE CCL BUFFER FOR COMMANDS
HRRM F,CTLIN+1 ;DUMMY UP BYTE POINTER
HRLI F,-200 ;MAKE IT AN IOWD
MOVEM F,TMPFIL+1
MOVSI F,(SIXBIT /LOA/)
MOVEM F,TMPFIL
MOVE N,[XWD 2,TMPFIL] ;POINTER FOR TMPCOR READ
TMPCOR N, ;READ AND DELETE LOA FILE
JRST RPGTMP ;NO SUCH FILE IN CORE, TRY DISK
IMULI N,5 ;GET CHAR COUNT
ADDI N,1
MOVEM N,CTLIN+2 ;STORE IN BUFFER HEADER
MOVEI N,700 ;BYTE POINTER FOR LOA FILE
HRLM N,CTLIN+1 ;BYTE POINTER NOW COMPLETE
SETOM TMPFLG ;MARK THAT A TMPCOR READ WAS DONE
SETZM NONLOD ;NOT YET STARTED SCAN
JRST RPGS3C ;GET BACK IN MAIN STREAM
RPGTMP: SETZM TMPFLG ;MARK AS NOT TMP>
INIT 17,1 ;SET UP DSK FOR COMMAND FILE INPUT.
SIXBIT /DSK/
XWD 0,CTLIN
JRST NUTS ;CAN'T INIT, GET INPUT FROM TTY.
MOVEI F,3
IFE STANSW,<
PJOB N, ;GET JOB NUMBER
LUP: IDIVI N,12 ;STRIP OFF LAST DIGIT
ADDI N+1,"0"-40 ;CONVERT TO SIXBIT
LSHC N+1,-6 ;SAVE
SOJG F,LUP ;3 DIGITS YET?
HLLZ N+2 ;YES.
HRRI (SIXBIT /LOA/) ;LOADER NAME PART OF FILE NAME.
MOVEM CTLNAM
MOVSI (SIXBIT /TMP/) ;AND EXTENSION.
MOVEM CTLNAM+1
>
IFN STANSW,<
MOVE N,[SIXBIT /QQLOAD/]
MOVEM N,CTLNAM
MOVSI N,(SIXBIT /RPG/)
MOVEM N,CTLNAM+1
>
SETZM CTLNAM+3
LOOKUP 17,CTLNAM ;FILE THERE?
JRST NUTS ;NO.
INIT 16,1 ;GET SET TO DELETE FILE
SIXBIT /DSK/
0
JRST RPGS3A ;GIVE UP
SETZM CTLNAM+3 ;PUT STUFF BACK AS IT WAS
LOOKUP 16,CTLNAM
JRST RPGS3B
SETZM CTLNAM ;SET FOR RENAME
IFN STANSW,<
SETZM CTLNAM+3 ;RENAME SHOULD REQUIRE THIS ANYWAY?
>
RENAME 16,CTLNAM
JFCL ;IGNORE FAILURE
RPGS3B: RELEASE 16, ;GET RID OF DEVICE
RPGS3A: SETZM NONLOD ;TO INDICATE WE HAVE NOT YET STARTED TO SCAN
;COMMAND IN FILE.
RPGS3: MOVEI CTLBUF
MOVEM JOBFF
INBUF 17,1 ;SET UP BUFFER.
RPGS3C: TTCALL 3,[ASCIZ /LOADING/] ;PRINT MESSAGE THAT WE ARE STARTING.
SKIPE NONLOD ;CONTIUATION OF COMMAND?
JRST RPGS2 ;YES, SPECIAL SETUP.
CCLCHN: MOVSI N,RPGF ;@ CHAIN FILES CYCLE FROM HERE
JRST CTLSET ;SET UP TTY
RPGS1: PUSHJ P,[TLNE F,ESW ;HERE FROM FOO@ COMMAND, STORE NAME.
JRST LDDT3 ;SAVE EXTENSION.
TLZE F,CSW!DSW ;AS NAME
MOVEM W,DTIN ;STORE AS NAME
SETZM W,DTIN1 ;TRY BLANK EXTENSION FIRST.
JRST LDDT4]
MOVEM 0,SVRPG ;SAVE 0 JUST IN CASE
SETZM NONLOD ;DETERMINE IF CONTINUATION.
MOVEI 0,2(B) ;BY SEEING IF ANY SYMBOLS LOADED.
CAME 0,JOBREL
SETOM NONLOD ;SET TO -1 AND SKIP CALLI
IFN TEMP,<SETZM TMPFLG>
MOVE 0,ILD1
MOVEM 0,RPG1
OPEN 17,OPEN1 ;KEEP IT PURE
JRST [MOVE W,RPG1
JRST ILD5]
LOOKUP 17,DTIN ;THE FILE NAME.
JRST [MOVE 0,SVRPG ;RESTORE AC0=F
TLOE F,ESW ;WAS EXT EXPLICIT?
JRST ILD9 ;YES, DON'T TRY AGAIN.
MOVEM 0,SVRPG ;SAVE AC0 AGAIN
MOVSI 0,(SIXBIT /TMP/) ;TRY TMP INSTEAD
MOVEM 0,DTIN1
PUSHJ P,LDDT4 ;SET UP PPN
JRST .-1] ;TRY AGAIN
JRST RPGS3
RPGS2: MOVSI 0,RPGF ;SET FLAG
IORM 0,F.C+N
TLO N,RPGF
MOVE 0,SVRPG
JRST LD2Q ;BACK TO INPUT SCANNING.
>
SUBTTL NORMAL INITIALIZATION
LD: IFE RPGSW,<BEG:>
IFN L,< HRRZM 0,LSPXIT
HRRZM W,LSPREL ;BY DBA AFTER JRA FOR UCI
MOVEI 0,0
HRRZM R,RINITL
RESET>
IFE L,<IFN RPGSW,<
HLLZS JOBERR ;MAKE SURE ITS CLEAR.>
RESET ;INITIALIZE THIS JOB
NUTS: SETZ N, ;CLEAR N
CTLSET: SETZB F,S ;CLEAR THESE AS WELL
HLRZ X,JOBSA ;TOP OF LOADER
HRLI X,V ;PUT IN INDEX
HRRZI H,JOBDA(X) ;PROGRAM BREAK
MOVE R,[XWD W,JOBDA] ;INITIAL RELOCATION>
MOVSI E,(SIXBIT /TTY/)
DEVCHR E,
TLNN E,10 ;IS IT A REAL TTY?
IFN RPGSW,<JRST [TLNN F,RPGF ;IN CCL MODE?>
EXIT ;NO, EXIT IF NOT TTY
IFN RPGSW,< TRO F,NOTTTY ;SET FLAG
JRST LD1] ;SKIP INIT>
INIT 3,1 ;INITIALIZE CONSOLE
SIXBIT /TTY/
XWD BUFO,BUFI
CALLEX: EXIT ;DEVICE ERROR, FATAL TO JOB
MOVEI E,TTY1
MOVEM E,JOBFF
INBUF 3,1
OUTBUF 3,1 ;INITIALIZE OUTPUT BUFFERS
OUTPUT 3, ;DO INITIAL REDUNDANT OUTPUT
LD1:
IFE L,< HRRZ B,JOBREL ;MUST BE JOBREL FOR LOADING REENTRANT>
IFN L,< MOVE B,JOBSYM ;USED INSTEAD OF JOBREL FOR SYMBOL TABLE FIXUPS>
HRRZM B,HISTRT
SUB B,SE3 ;INITIALIZE SYMBOL TABLE POINTER
CAILE H,1(B) ;TEST CORE ALLOCATION>
JRST [HRRZ B,JOBREL;TOP OF CORE
ADDI B,2000 ;1K MORE
CORE B, ;TRY TO GET IT
EXIT ;INSUFFICIENT CORE, FATAL TO JOB
JRST LD1] ;TRY AGAIN
IFN EXPAND,< IFE STANSW ,<SETZ S,
CORE S, ;GET PERMITTED CORE
JFCL
LSH S,12
SUBI S,1 ;CONVERT TO NUMBER OF WORDS
MOVEM S,ALWCOR ;SAVE IT FOR XPAND TEST>>
IFN STANSW,<
MOVEI S,-1 ;THERE IS ALWAYS CORE AT STANFORD!!
MOVEM S,ALWCOR >
IFN PURESW,<MOVE S,[XWD HICODE,LOWCOD]
BLT S,LOWCOD+CODLN-1>
IFE L,< MOVS E,X ;SET UP BLT POINTER
HRRI E,1(X)>
IFN L,<MOVS E,H
HRRI E,1(H)>
SETZM -1(E) ;ZERO FIRST WORD
BLT E,(B) ;ZERO CORE UP TO THE SYMBOL AREA
HRRZ S,B ;INITIALIZE UNDEF. POINTER
HRR N,B ;INITIALIZE PROGRAM NAME POINTER
IFE L,< HRRI R,JOBDA ;INITIALIZE THE LOAD ORIGIN
MOVE E,COMM ;SET .COMM. AS THE FIRST PROGRAM
MOVEM E,1(B) ;STORE IN SYMBOL TABLE
HRRZM R,2(B) ;STORE COMMON ORIGIN>
MOVEI E,F.C ;INITIALIZE STATE OF THE LOADER
BLT E,B.C
SETZM MDG ;MULTIPLY DEFINED GLOBAL COUNT
SETZM STADDR ;CLEAR STARTING ADDRESS
IFN REENT,<MOVSI W,1
MOVEM W,HVAL1
MOVEM W,HVAL
MOVEM X,LOWX
SETZM HILOW
MOVEM R,LOWR
HRRZI W,1
IFE STANSW,< SETUWP W, ;SETUWP UUO.
TRO F,NOHI6 ;PDP-6 COMES HERE.>
MOVEM F,F.C ;PDP-10 COMES HERE.>
IFE L,< IFN STANSW,< TRO F,DMNFLG ;ASSUME /B IS SAID...
MOVEM F,F.C ;AND SAVE>>
IFN SAILSW,<MOVE W,[XWD -RELLEN-1,LIBFLS-1] ;SET UP POINTERS
MOVEM W,LIBPNT# ;IN THE FORM OF AOBJN WORDS
MOVE W,[XWD -RELLEN-1,PRGFLS-1]
MOVEM W,PRGPNT#>
IFE L,< MOVSI W,254200 ;STORE HALT IN JOB41
MOVEM W,JOB41(X) ;...>
IFN L,< MOVE W,JOBREL
HRRZM W,OLDJR>
IFN SPCHN,<SETZM CHNACB ;USED AS DEV INITED FLAG TOO>
IFN NAMESW,<SETZM CURNAM>
IFN FAILSW,<MOVEI W,440000 ;SET UP THE SPECIAL BITS OF HEADNUM(ADD+POLISH)
MOVEM W,HEADNM
SETZM POLSW ;SWITCH SAYS WE ARE DOING POLISH
MOVEI W,PDLOV ;ENABLE FOR PDL OV
MOVEM W,JOBAPR
MOVEI W,200000
CALLI W,16
SETZM LINKTB ;ZERO OUT TABLE OF LINKS
MOVE W,[XWD LINKTB,LINKTB+1]
BLT W,LINKTB+20>
IFN DMNSW,<MOVEI W,SYMPAT
MOVEM W,KORSP>
IFN KUTSW,< IFE STANSW,<SETOM CORSZ>>
IFN KUTSW,< IFN STANSW,<SETZM CORSZ>> ;ASSUME /K FOR KIDS...
IFN RPGSW,<JRST LD2Q>
LD2: IFN RPGSW,<MOVSI B,RPGF ;HERE ON ERRORS, TURN OFF RPG
ANDCAM B,F.C+N ;IN CORE>
;LOADER SCAN FOR FILE NAMES
LD2Q: MOVSI B,F.C ;RESTORE ACCUMULATORS
BLT B,B
MOVE P,PDLPT ;INITIALIZE PUSHDOWN LIST
SETZM BUFI2 ;CLEAR INPUT BUFFER POINTER
IFE PP,< SETZM ILD1 ;CLEAR INPUT DEVICE NAME>
IFN PP,< MOVSI T,(SIXBIT /DSK/) ;ASSUME DSK.
MOVEM T,ILD1
SETZM OLDDEV ;TO MAKE IT GO BACK AFTER /D FOR LIBSR>
SETZM DTIN ;CLEAR INPUT FILE NAME
LD2B: RELEAS 1, ;RELEASE BINARY INPUT DEVICE
IFN RPGSW,< TLNE N,RPGF ;NOT IF DOING CCL STUFF
JRST LD2BA>
MOVEI T,"*"
IDPB T,BUFO1 ;OUTPUT ASTERISK TO START INPUT
OUTPUT 3,
LD2BA: TLZ F,FULLSW+ASW+ISW+CSW+ESW+SKIPSW+SLIBSW+REWSW
LD2BP: TLNE F,LIBSW ;WAS LIBRARY MODE ON?
TLO F,SKIPSW ;YES, NORMAL MODE IS SKIPPING
LD2D: IFN PP,<SETZM PPN ;DON'T REMEMBER PPN FROM ONE FILE TO NEXT.
LD2DB: SKIPE W,OLDDEV ;RESET DEVICE IF NEEDED.
CAMN W,ILD1 ;IS IT SAME?
JRST LD2DA ;YES, FORGET IT.
TLZ F,ISW+DSW+FSW+REWSW
MOVEM W,ILD1>
LD2DA: MOVEI W,0 ;INITIALIZE IDENTIFIER SCAN
MOVEI E,6 ;INITIALIZE CHARACTER COUNTER
MOVE V,LSTPT ;INITIALIZE BYTE POINTER TO W
TLZ F,SSW+DSW+FSW ;LEAVE SWITCH MODE
LD3: IFN RPGSW,<TLNE N,RPGF ;CHECK RPG FEATURE
JRST RPGRD>
SOSG BUFI2 ;DECREMENT CHARACTER COUNTER
INPUT 3, ;FILL TTY BUFFER
ILDB T,BUFI1 ;LOAD T WITH NEXT CHARACTER
LD3AA: CAIN T,175 ;OLD ALTMOD
MOVEI T,33 ;NEW ONE
CAIL T,140 ;LOWER CASE?
TRZ T,40 ;CONVERT TO UPPER CASE
MOVE Q,T
HRLM Q,LIMBO ;SAVE THIS CHAR.
MOVSS LIMBO ;AND LAST ONE
IDIVI Q,11 ;TRANSLATE TO 4 BIT CODE
LDB Q,LD8(A) ;LOAD CLASSIFICATION CODE
CAIGE Q,4 ;MODIFY CODE IF .GE. 4
TLNN F,SSW ;MODIFY CODE IF SWITCH MODE OFF
ADDI Q,4 ;MODIFY CLASS. CODE FOR DISPATCH
IFN SYMARG,<CAIL Q,20 ;SKIP UNLESS SECOND FORM OF DISPATCH
JRST LD3AB ;DIFFERENT DISPATCH>
HRRZ A,LD3A(Q) ;LOAD RH DISPATCH ENTRY
CAIL Q,10 ;SKIP IF CORRECT DISPATCH ENTRY
HLRZ A,LD3A-10(Q) ;LOAD LH DISPATCH ENTRY
JRST @A ;JUMP TO INDICATED LOCATION
;COMMAND DISPATCH TABLE
LD3A: XWD LD3,LD7B ;IGNORED CHAR, BAD CHAR (SWITCH)
XWD LD6A,LD6 ;</> OR <(>, LETTER (SWITCH)
XWD LD5,LD6C ;<:>, DIGIT (SWITCH ARG.)
XWD LD5A,LD6D ;<.>, ESCAPE SWITCH MODE <)>
XWD LD5C,LD7 ;<=> OR <L. ARROW>, BAD CHAR.
XWD LD5B,LD4 ;<,>, ALPHABETIC CHAR.
XWD LD5D,LD4 ;<CR.>, NUMERIC CHAR.
XWD LD5E1,LD7 ;<ALT MODE>, BAD CHAR. <)>
IFN SYMARG,<XWD LD7,LD10 ;BAD CHAR,&>
IFN RPGSW,<
RPGRD1: MOVNI T,5
ADDM T,CTLIN+2
AOS CTLIN+1
RPGRD: SOSG CTLIN+2 ;CHECK CHARACTER COUNT.
JRST [IFN TEMP,<SKIPE TMPFLG ;TMPCOR UUO READ DONE?
JRST LD2 ;YES, JUST LEAVE>
IN 17,0
JRST .+1
STATO 17,740000
JRST LD2
JSP A,ERRPT
SIXBIT /ERROR WHILE READING COMMAND FILE%/
JRST LD2]
IBP CTLIN+1 ;ADVANCE POINTER
MOVE T,@CTLIN+1 ;AND CHECK FOR LINE #
TRNE T,1
JRST RPGRD1
LDB T,CTLIN+1 ;GET CHR
JRST LD3AA ;PASS IT ON>
IFN SYMARG,<
LD3AB: ROT Q,-1 ;CUT Q IN HALF
HRRZ A,LD3A(Q) ;PULL OFF RIGHT HALF OF TABLE ENTRY
JUMPGE Q,@A ;WHICH IS CORRECT FOR EVEN ENTRIES
HLRZ A,LD3A(Q) ;BUT USE LEFT HALF FOR ODD ENTRIES
JRST @A>
SUBTTL CHARACTER HANDLING
;ALPHANUMERIC CHARACTER, NORMAL MODE
LD4: SOJL E,LD3 ;JUMP IF NO SPACE FOR CHAR IN W
CAIGE T,141 ;WORRY ABOUT LOWER CASE LETTERS
SUBI T,40 ;CONVERT FROM ASCII TO SIXBIT
IDPB T,V ;DEPOSIT CHAR OF IDENTIFIER IN W
TLO F,DSW ;SET IDENTIFIER FLAG
JRST LD3 ;RETURN FOR NEXT CHARACTER
;DEVICE IDENTIFIER DELIMITER <:>
LD5: PUSH P,W ;SAVE W
TLOE F,CSW ;TEST AND SET COLON FLAG
PUSHJ P,LDF ;FORCE LOADING
POP P,W ;RESTORE W
TLNE F,ESW ;TEST SYNTAX
JRST LD7A ;ERROR, MISSING COMMA ASSUMED
JUMPE W,LD2D ;JUMP IF NULL DEVICE IDENTIFIER
MOVEM W,ILD1 ;STORE DEVICE IDENTIFIER
IFN PP,<MOVEM W,OLDDEV ;WE HAVE A NEW ONE, DO IGNORE OLD.>
TLZ F,ISW+DSW+FSW+REWSW ;CLEAR OLD DEVICE FLAGS
JRST LD2D ;RETURN FOR NEXT IDENTIFIER
;FILE NAME EXTENSION IDENTIFIER DELIMITER <.>
LD5A: IFN SYMARG,<
TRNE F,ARGFL ;IS "." SPECIAL
JRST LD4 ;YES,RADIX-50>
TLOE F,ESW ;TEST AND SET EXTENSION FLAG
JRST LD7A ;ERROR, TOO MANY PERIODS
TLZE F,CSW+DSW ;SKIP IF NULL IDENT AND NO COLON
MOVEM W,DTIN ;STORE FILE IDENTIFIER
JRST LD2D ;RETURN FOR NEXT IDENTIFIER
;INPUT SPECIFICATION DELIMITER <,>
LD5B:
IFN PP,<TLZE N,PPCSW ;READING PP #?
JRST [
IFE STANSW,< HRLM D,PPN ;STORE PROJ #
JRST LD6A1 ];GET PROG #>
IFN STANSW,< PUSHJ P,RJUST ;RIGHT JUSTIFY W
HRLM W,PPN ;STORE PROJ NAME
JRST LD2DB ];GET PROG NAME>
PUSHJ P,RBRA ;CHECK FOR MISSING RBRA>
SETOM LIMBO ;USED TO INDICATE COMMA SEEN
TLZN F,FSW ;SKIP IF PREV. FORCED LOADING
PUSHJ P,FSCN2 ;LOAD (FSW NOT SET)
JRST LD2BP ;RETURN FOR NEXT IDENTIFIER
LD5B1: TLNE F,ESW ;TEST EXTENSION FLAG
JRST LDDT3 ;EXPLICIT EXTENSION IDENTIFIER
TLZN F,CSW+DSW ;SKIP IF IDENT. OR COLON
POPJ P,
MOVEM W,DTIN ;STORE FILE IDENTIFIER
JRST LDDT2 ;ASSUME <.REL> IN DEFAULT CASE
;OUTPUT SPECIFICATION DELIMITER <=> OR <LEFT ARROW>
;OR PROJ-PROG # BRACKETS <[> AND <]>
LD5C:
IFN SPCHN,<CAIN T,"=" ;DO A /= AS SWITCH
TLNN F,SSW
SKIPA
JRST LD6>
IFN RPGSW,<CAIN T,"@" ;CHECK FOR * COMMAND.
JRST RPGS1>
IFN PP,<CAIN T,"[" ;PROJ-PROG #?
JRST [TLO N,PPSW+PPCSW ;SET FLAGS
MOVEM W,PPNW ;SAVE W
MOVEM E,PPNE ;SAVE E
MOVEM V,PPNV ;SAVE V
IFE STANSW,< JRST LD6A2]> ;READ NUMBERS AS SWITCHES
IFN STANSW,< JRST LD2DB]>
CAIN T,"]" ;END OF PP #?
JRST [PUSHJ P,RBRA ;PROCESS RIGHT BRACKET
JRST LD3] ;READ NEXT IDENT>
TLOE F,ASW ;TEST AND SET LEFT ARROW FLAG
JRST LD7A ;ERROR, MISPLACED LEFT ARROW
PUSHJ P,LD5B1 ;STORE IDENTIFIER
TLZN F,ESW ;TEST EXTENSION FLAG
MOVSI W,554160 ;ASSUME <.MAP> IN DEFAULT CASE
MOVEM W,DTOUT1 ;STORE FILE EXTENSION IDENTIFIER
MOVE W,DTIN ;LOAD INPUT FILE IDENTIFIER
MOVEM W,DTOUT ;USE AS OUTPUT FILE IDENTIFIER
IFN SPCHN,<MOVEM W,CHNENT ;AND FOR SPECAIL CHAINING>
IFN PP,<MOVE W,PPN ;PROJ-PROG #
MOVEM W,DTOUT+3 ;...>
MOVE W,ILD1 ;LOAD INPUT DEVICE IDENTIFIER
MOVEM W,LD5C1 ;USE AS OUTPUT DEVICE IDENTIFIER
IFN PP,<SKIPE W,OLDDEV ;RESTORE OLD
MOVEM W,ILD1>
;INITIALIZE AUXILIARY OUTPUT DEVICE
TRZ F,TTYFL
TLZE N,AUXSWI+AUXSWE ;FLUSH CURRENT DEVICE
RELEASE 2, ;...
DEVCHR W, ;IS DEVICE A TTY?
TLNE W,10 ;...
JRST [TRO F,TTYFL ;TTY IS AUX. DEV.
JRST LD2D] ;YES, SKIP INIT
OPEN 2,OPEN2 ;KEEP IT PURE
JRST ILD5A
TLNE F,REWSW ;REWIND REQUESTED?
UTPCLR 2, ;DECTAPE REWIND
TLZE F,REWSW ;SKIP IF NO REWIND REQUESTED
MTAPE 2,1 ;REWIND THE AUX DEV
MOVEI E,AUX ;SET BUFFER ORIGIN
MOVEM E,JOBFF
OUTBUF 2,1 ;INITIALIZE SINGLE BUFFER
TLO N,AUXSWI ;SET INITIALIZED FLAG
IFN LNSSW,<EXCH E,JOBFF
SUBI E,AUX
IDIV C,E
OUTBUF 2,(C)>
JRST LD2D ;RETURN TO CONTINUE SCAN
;RIGHT SQUARE BRACKET (PROJ-PROG NUMBERS)
IFN PP,<
RBRA: TLZN N,PPSW ;READING PP #?
POPJ P, ;NOPE, RETURN
TLZE N,PPCSW ;COMMA SEEN?
JRST LD7A ;NOPE, INDICATE ERROR
IFE STANSW,<HRRM D,PPN ;STASH PROG NUMBER
TLZ F,SSW ;AND TURN OFF SWITCH MODE>
IFN STANSW,<PUSHJ P,RJUST ;RIGHT JUSTIFY W
HRRM W,PPN ;STASH PROG NAME>
MOVE W,PPNW ;PICKUP OLD IDENT
MOVE E,PPNE ;RESTORE CHAR COUNT
MOVE V,PPNV ;RESTORE BYTE PNTR
POPJ P, ;TRA 1,4
;RIGHT JUSTIFY W
IFN STANSW,<
RJUST: JUMPE W,LD7A ;NOTHING TO RIGHT JUSTIFY
TRNE W,77 ;IS W RJUSTED YET?
POPJ P, ;YES, TRA 1,4
LSH W,-6 ;NOPE, TRY AGAIN
JRST .-3 ;...>>
IFN SYMARG,<
;& SELECTS A SYMBOL RATHER THAN ANUMBER FOR A SWITCH ARGUMENT
;& MUST ALSO FOLLOW THW SYMBOL; THE FORM IS /&SYMBOL&SWITHCH
LD10: TRC F,ARGFL ;SET OR CLEAR SPECIAL CHARS.
TLCE F,SSW ;IF IN SWITCH MODE, EXIT TO GET IDENTIFIER
JRST LD10B
PUSHJ P,ASCR50 ;IF NOT, REENTER IT, CONVERT IDENTIFIER TO R50
PUSHJ P,SDEF ;AND SEE IF IT EXISTS
JRST LD10A ;YES IT DOES
PUSHJ P,PRQ ;NO, COMPLAIN. OUTPUT ?
PUSHJ P,SPACE ;FOLLOWED BY A SPACE
PUSHJ P,PRNAME ;FOLLOWED BY THIS SYMBOL
ERROR 0,</ DOESN'T EXIST@/>
JRST LD2
LD10A: MOVE D,2(A) ;SET D=VALUE OF SYMBOL AS NUMERIC ARG
TLZ F,DSW!FSW
MOVEI E,6 ;INITIALIZE NEW IDENTIFIER SCAN
MOVE V,LSTPT ;(W IS ALREADY 0)
JRST LD3 ;NOW EAT SWITCH AND CONTINUE PROCESSING COMMAND
LD10B: PUSHJ P,FSCN1 ;FORCE SCAN TO COMPLETION TO MAKE SURE FILE IS LOADED
JRST LD2DA>
IFN SYMARG,<
;CONVERT SYMBOL IN W TO RADIX-50 IN C
;ALSO USES A
ASCR50: MOVEI A,0
R50A: MOVEI C,0
ROTC W,6 ;C IS NEXT SIXBIT CHAR
CAIGE C,20
JRST R50B ;UNDER 20, MAY BE ., $, OR %
CAILE C,31
JRST R50C ;OVER 31
SUBI C,20-1 ;IS NUMBER
R50D: IMULI A,50
ADD A,C
JUMPN W,R50A ;LOOP FOR ALL CHARS
MOVE C,A ;WIND UP WITH CHAR IN C
TLO C,040000 ;MAKE IT GLOBAL DEFINITION
POPJ P,
R50B: JUMPE C,R50D ;OK IF SPACE
CAIE C,16 ;TEST IF .
JRST .+3 ;NO
MOVEI C,45 ;YES
JRST R50D
CAIE C,4 ;SKIP IF $
R50E: MOVEI C,5 ;ASSUME % IF NOTHING ELSE
ADDI C,42
JRST R50D
R50C: CAIGE C,41
JRST R50E ;BETWEEN 31 AND 41
CAILE C,72
JRST R50E ;OVER 72
SUBI C,41-13 ;IS LETTER
JRST R50D>
;DEFINE PUTS A SYMBOL IN THE UNDEFINED SYMBOL TABLE
;SO LOADER CAN SCAN LIBRARY AND LOAD PROGRAMS BEFORE THEY ARE REQUESTED
;THE FORM IS /&SYMBOL# WHERE SYMBOL IS CONVERTED TO RADIX-50
IFN SYMARG,<
DEFINE: PUSHJ P,ASCR50 ;CONVRT TO R-50
MOVEI W,-2(S) ;WHERE SYMBOL WILL GO
CAIG W,(H) ;ENOUGH ROOM
IFN EXPAND,<PUSHJ P,[PUSHJ P,XPAND
TLOA F,FULLSW
JRST POPJM3
POPJ P,]>
IFE EXPAND,<TLO F,FULLSW>
SUB S,SE3 ;ADJUST POINTER
MOVEM C,1(S) ;R-50 SYMBOL
SETZM 2(S) ;VALUE
TLZ F,DSW!SSW ;TURN OFF SWITCHES
JRST LD2D ;CONTINUE TO SCAN
>
SUBTTL TERMINATION
;LINE TERMINATION <CARRIAGE RETURN>
LD5D:
IFN PP,<PUSHJ P,RBRA ;CHECK FOR UNTERMINATED PP #>
SKIPGE LIMBO ;WAS LAST CHAR. BEFORE CR A COMMA?
TLO F,DSW ;YES ,SO LOAD ONE MORE FILE
PUSHJ P,FSCN ;FORCE SCAN TO COMPLETION
JRST LD2B ;RETURN FOR NEXT LINE
;TERMINATE LOADING <ALT MODE>
LD5E: JUMPE D,LD5E1 ;ENTER FROM G COMMAND
TLO N,ISAFLG ;AND IGNORE ANY STARTING ADDRESS TO COME
HRRZM D,STADDR ;USE NUMERIC STARTING ADDRESS
LD5E1: PUSHJ P,CRLF ;START A NEW LINE
IFN RPGSW,<RELEASE 17,0 ;RELEASE COMMAND DEVICE>
PUSHJ P,SASYM ;SETUP JOBSA,JOBFF,JOBSYM,JOBUSY
MOVE W,[SIXBIT ?LOADER?] ;FINAL MESSAGE
PUSHJ P,BLTSET ;SETUP FOR FINAL BLT
RELEASE 2, ;RELEASE AUX. DEV.
RELEASE 1,0 ;INPUT DEVICE
RELEASE 3,0 ;TTY
IFN SPCHN,<RELEASE 4,0 ;SPECIAL CHAINING CHANEL>
IFN NAMESW,<HRRZ W,HISTRT ;IN CASE NO NAME SET, USE FIRST LOADED
MOVE W,-1(W)
SKIPN CURNAM
PUSHJ P,LDNAM
SKIPE W,CURNAM
CAMN W,[SIXBIT /MAIN/] ;FORTRAN MAIN PROG, OR MACRO NO TITLE
SKIPE W,PRGNAM ;USE BINARY FILE NAME IN EITHER CASE
SETNAM W, ;SETNAME>
IFN L,< MOVE W,LSPREL ; BY DBA AFTER JRA FOR UCI
JRST @LSPXIT>
IFE L,< ;NONE OF THIS NEEDED FOR LISP
IFN PURESW,<
MOVE V,[XWD HHIGO,HIGO]
BLT V,HIGONE ;MOVE DOWN CODE TO EXIT>
TLNN N,EXEQSW ;DO WE WANT TO START
JRST LD5E3
IFN RPGSW,<TLNN N,RPGF ;IF IN RPG MODE
JRST LD5E2
HRRZ C,JOBERR ;CHECK FOR ERRORS
JUMPE C,LD5E2 ;NONE
EXDLTD: TTCALL 3,[ASCIZ /?EXECUTION DELETED
/]
JRST LD5E3>
LD5E2: HRRZ W,JOBSA(X)
TLNE N,DDSW ;SHOULD WE START DDT??
HRRZ W,JOBDDT(X)
IFN RPGSW,< TLNE N,RPGF ;IF IN RPG MODE
JUMPE W,[TTCALL 3,[ASCIZ /?NO STARTING ADDRESS
/]
JRST EXDLTD]>
JUMPE W,LD5E3 ;ANYTHING THERE?
TLOA W,(JRST) ;SET UP A JRST
LD5E3: SKIPA W,CALLEX ;NO OR NO EXECUTE, SET CALLI 12
TTCALL 3,[ASCIZ /EXECUTION
/]
IFN LDAC,< HRLZ P,BOTACS ;SET UP FOR ACBLT
MOVEM W,JOBBLT+1(X) ;SET JOBBLT
MOVE W,[BLT P,P]
MOVEM W,JOBBLT(X)>
MOVSI LSTAC,LODACS ;SET UP TO BLT BLT CODE INTO ACS
BLT LSTAC,LSTAC
IFN KUTSW,<SKIPGE E,CORSZ ;DO WE WANT CORE ADJUST
MOVE CORAC,JFCLAC ;NO, CLEAR COREUUO>
IFE LDAC,<MOVE LSTAC,W ;SET END CONDITION>
IFN REENT,<
MOVSI V,LD ;DOES IT HAVE HISEG
JUMPG V,HINOGO ;NO,DON'T DO CORE UUO
MOVSI V,1 ;SET HISEG CORE NONE ZERO
JRST HIGO ;AND GO>
IFE REENT,<JRST 0>
LODACS: PHASE 0
BLT Q,(A) ;BLT CODE DOWN
IFN KUTSW,<CORAC: CORE E, ;CUT BACK CORE
JFCLAC: JFCL ;SHOULD NEVER HAVE AN ERROR SINCE REDUCING CORE>
LSTAC: IFN LDAC,<JRST JOBBLT>
IFE LDAC,<EXIT>
DEPHASE
> ;;;;END OF IFE L AT BEGINNING OF THIS PAGE
SUBTTL PRINT FINAL MESSAGE
; SET UP BLT AC'S, SETDDT, RELEAS
BLTSET: IFN RPGSW,<IFE K,<
JUMPE W,.+4 ;NO MESSAGE FROM CHAIN IN CCL@>>
PUSHJ P,FCRLF ;A RETURN
PUSHJ P,PWORD ;AND CHAIN OR LOADER
PUSHJ P,SPACE
IFN FAILSW,<MOVSI Q,-20 ;FINISH UP LINK STUFF
FREND: HLRZ V,LINKTB+1(Q)
JUMPE V,NOEND
HRRZ A,LINKTB+1(Q)
IFN REENT,<CAMGE V,HVAL1
SKIPA X,LOWX
MOVE X,HIGHX>
IFN L,<CAML V,RINITL>
HRRM A,@X ;PUT END OF LINK CHAIN IN PROPER PLACE
NOEND: AOBJN Q,FREND
IFN REENT,<MOVE X,LOWX ;RESET THINGS>>
IFN KUTSW,<SKIPGE C,CORSZ ;NEG MEANS DO NOT KUT BACK CORE
JRST NOCUT
JUMPE C,MINCUT ;0 IS KUT TO MIN. POSSIBLE
LSH C,12 ;GET AS A NUMBER OF WORDS
SUBI C,1
CAMG C,JOBREL ;DO WE NEED MORE THAN WE HAVE??
JRST TRYSML ;NO, SEE IF NUMBER REQUESTED IS TOO SMALL
MOVEI Q,0
CORE Q,
JFCL ;WE JUST WANT TO KNOW HOW MUCH
HRRZS Q
CAMGE Q,CORSZ
JRST CORERR
JRST NOCUT1 ;SET FOR DO NOT CHANGE SIZE
TRYSML: CAIG C,(R) ;IS DESIRED AMOUNT BIGGER THAN NEEDED
MINCUT: HRRZ C,R ;GET MIN AMOUNT
IORI C,1777 ;CONVERT TO A 1K MULTIPLE
IFN DMNSW,< TRNN F,DMNFLG ;DID WE MOVE SYMBOLS??
SKIPN JOBDDT(X) ;IF NOT IS DDT THERE??
JRST .+2>
IFE DMNSW,<SKIPE JOBDDT(X) ;IF NO SYMBOL MOVING JUST CHECK DDT>
JRST NOCUT ;DO NOT CUT IF SYMBOLS AT TOP AND DDT
NOCUT1: MOVEM C,JOBREL(X) ;SAVE FOR CORE UUO
MOVEM C,CORSZ ;SAVE AWAY FOR LATER
JRST .+2
NOCUT: SETOM CORSZ ;SET FOR NO CUT BACK>
IFN RPGSW,<IFE K,<
JUMPE W,NOMAX ;NO MESSAGE IF CHAIN IN CCL@>>
IFN L,<HRRZ Q,JOBREL
SUB Q,OLDJR ;PROPER SIZE>
IFE L,<HRRZ Q,JOBREL(X)>
LSH Q,-12 ;GET CORE SIZE TO PRINT
ADDI Q,1
PUSHJ P,RCNUM
IFN REENT,<MOVE Q,HVAL
SUB Q,HVAL1
HRRZS Q
JUMPE Q,NOHY ;NO HIGH SEGMENT
MOVEI T,"+"-40 ;THERE IS A HISEG
PUSHJ P,TYPE
LSH Q,-12
ADDI Q,1
PUSHJ P,RCNUM
NOHY:>
MOVE W,[SIXBIT /K CORE/]
PUSHJ P,PWORD
PUSHJ P,CRLF
IFE L,<
IFN RPGSW,<TLNE N,RPGF
JRST NOMAX ;DO NOT PRINT EXTRA JUNK IN RPG MODE>
MOVE Q,JOBREL
LSH Q,-12
ADDI Q,1
PUSHJ P,RCNUM ;PRINT MAX LOW CORE SIZE
IFN REENT,< SKIPE Q,JOBHRL ;GET SIZE OF HIGH SEGMENT
PUSHJ P,[MOVEI Q,400001(Q) ;CLEAR HIGH ORDER BIT
MOVEI T,"+"-40 ;PRINT A HIGH CORE PART
PUSHJ P,TYPE
LSH Q,-12
JRST RCNUM]>
MOVE W,[SIXBIT /K MAX/]
PUSHJ P,PWORD
IFN DMNSW,<TRNN F,DMNFLG>
SKIPN JOBDDT(X)
SKIPA Q,JOBREL(X)
MOVEI Q,1(S) ;FIND THE AMOUNT OF SPACE LEFT OVER
SUB Q,JOBFF(X)
PUSHJ P,RCNUM
MOVE W,[SIXBIT / WORDS/]
PUSHJ P,PWORD
MOVE W,[SIXBIT / FREE/]
PUSHJ P,PWORD
PUSHJ P,CRLF >
NOMAX: MOVE W,JOBDDT(X)
SETDDT W,
IFE TEN30,<HRLI Q,20(X) ;SET UP BLT FOR CODE
HRRI Q,20>
IFN TEN30,<HRLI Q,JOBDDT(X)
HRRI Q,JOBDDT>
HRRZ A,R
POPJ P, ;WE HAVE SET R UP BY CLEVER CODE IN SASYM
IFN KUTSW,<CORERR: TTCALL 3,[ASCIZ /?NOT ENOUGH CORE
/]
EXIT>
SUBTTL SET UP JOBDAT
SASYM: TLNN F,NSW
PUSHJ P,LIBF ;SEARCH LIBRARY IF REQUIRED
PUSHJ P,FSCN ;FORCE END OF SCAN
IFN ALGSW,<MOVE C,[RADIX50 44,%OWN]
MOVE W,%OWN ;GET VALUE
TRNE F,ALGFL ;IF ALGOL PROG LOADED
PUSHJ P,SYMPT ;DEFINE %OWN>
IFN RPGSW,<HLRE A,S
MOVNS A
LSH A,-1
ADD A,JOBERR
HRRM A,JOBERR>
PUSHJ P,PMS1 ;PRINT UNDEFS
HRRZ A,H ;DO NOT CLOBBER H IF STILL INSERTING SYMBOLS
SUBI A,(X) ;HIGHEST LOC LOADED INCLUDES LOC STMTS
CAILE A,(R) ;CHECK AGAINST R
HRR R,A ;AND USE LARGER
IFE L,< HRRZ A,STADDR ;GET STARTING ADDRESS
HRRM A,JOBSA(X) ;STORE STARTING ADDRESS
HRRZM R,JOBFF(X) ;AND CURRENT END OF PROG
HRLM R,JOBSA(X)>
IFN DMNSW,<MOVE C,[RADIX50 44,PAT..] ;MARK PATCH SPACE FOR RPG
MOVEI W,(R)
SKIPE JOBDDT(X) ;BUT ONLY IF DDT LOADED
PUSHJ P,SYMPT
IFN REENT,<TRNE F,HISYM ;SHOULD SYMBOLS GO IN HISEG?
JRST BLTSYM ;YES>>
IFN DMNSW!LDAC,< ;ONLY ASSEMBLE IF EITHER SET
IFE LDAC,< TRNN F,DMNFLG ;GET EXTRA SPACE IF SYMBOLS
JRST NODDT ;MOVED OR IF LOADING ACS>
IFE DMNSW,< MOVEI A,20 ;FOR LOADING ACS>
IFN DMNSW,< MOVE A,KORSP
IFN LDAC,< TRNN F,DMNFLG ;ONLY 20 IF SYMBOLS NOT MOVED
MOVEI A,20>>
ADDI A,(R) ;GET ACTUAL PLACE TO PUT END OF SPACE
ADDI A,(X)
CAIL A,(S) ;DO NOT OVERWRITE SYMBOLS
IFN EXPAND,<JRST [PUSHJ P,XPAND>
PUSHJ P,MORCOR
IFN EXPAND,< JRST .-1]>
IFN LDAC,<HRRM R,BOTACS ;SAVE BOTTOM OF WHERE WE PUT ACS
HRRZ A,R
ADDI A,(X)
HRL A,X ;SET UP BLT FROM (X) TO R(X)
MOVEI Q,17(A)
BLT A,(Q)>>
IFN DMNSW,<TRNN F,DMNFLG ;NOW THE CODE TO MOVE SYMBOLS
JRST NODDT
HRRZ A,R
ADD A,KORSP
MOVE W,A ;SAVE POINTER TO FINAL LOC OF UNDEFS
ADDI A,(X)
HLLZ Q,S ;COMPUTE LENGTH OF SYMBOL TABLE
ADD Q,B
HLROS Q
MOVNS Q
ADDI Q,-1(A) ;GET PLACE TO STOP BLT
HRLI A,1(S) ;WHERE TO BLT FROM
SUBI W,1(S) ;GET AMOUNT TO CHANGE S AND B BY
BLT A,(Q) ;MOVE SYMBOL TABLE
ADD S,W
ADD B,W ;CORRECT S AND B FOR MOVE
HRRI R,1(Q) ;SET R TO POINT TO END OF SYMBOLS
SUBI R,(X)
SKIPN JOBDDT(X) ;IS DDT LOADED
JRST NODDT ;ON THE CONTRARY, DO LEAVE SYMBOLS!!!!!
HRRM R,JOBFF(X)
HRLM R,JOBSA(X) ;AND SAVE AWAY NEW JOBFF
IFN LDAC,<SKIPA> ;SKIP THE ADD TO R
NODDT:>
IFN LDAC,<ADDI R,20> ;MAKE SURE R IS CORRECT FOR BLT
MOVE A,B
ADDI A,1 ;SET UP JOBSYM, JOBUSY
IFE L,<MOVEM A,JOBSYM(X)>
IFN L,<MOVEM A,JOBSYM>
MOVE A,S
ADDI A,1
IFE L,<MOVEM A,JOBUSY(X)
MOVE A,HISTRT ;TAKE POSSIBLE REMAP INTO ACCOUNT
MOVEM A,JOBREL(X) ;SET UP FOR IMEDIATE EXECUTION>
IFN L,<MOVEM A,JOBUSY>
IFN REENT,<
SKIPE A,HILOW ;SET UP TOP LOC OF LOW CORE EXCLUDING BLOCKS
SUBI A,1(X) ;IF NON-ZERO THEN IT NEEDS RELOCATION
HRLM A,JOBCOR(X)
TRNN F,SEENHI
POPJ P,
HRRZ A,HVAL
HRRM A,JOBHRL(X)
SUB A,HVAL1
HRLM A,JOBHRL(X)>
POPJ P,
SUBTTL BLT SYMBOL TABLE INTO HIGH SEGMENT
IFN DMNSW&REENT,<
BLTSYM: MOVE Q,HVAL ;GET ORIGIN OF HISEG
CAMN Q,HVAL1 ;HAS IT CHANGED?
JRST NOBLT ;NO
HLLZ Q,S ;COMPUTE LENGTH OF SYMBOL TABLE
HLRS S ;PUT NEG COUNT IN BOTH HALVES
JUMPE S,.+2 ;SKIP IF S IS ZERO
HRLI S,-1(S) ;SUB 1 FROM LEFT TO FIX CARRY PROBLEM
ADD Q,B
HLROS Q
MOVNS Q
ADD Q,HVAL ;ADD LENGTH OF HISEG
SUB Q,HVAL1 ;BUT REMOVE ORIGIN
ADD Q,HISTRT ;START OF HISEG IN CORE
HRRZS Q ;CLEAR INDEX FROM Q
ADD Q,KORSP ;SAVE SPACE FOR SYMBOL PATCHES
CORE Q, ;EXPAND IF NEEDED
PUSHJ P,MORCOR
PUSH P,B ;SAVE B
SOJ B, ;REMOVE CARRY FROM ADD TO FOLLOW
MOVSS B ;SWAP SYMBOL POINTER
ADD B,JOBREL
HRRM B,(P) ;SAVE NEW B
MOVE Q,JOBREL
ADD B,S ;INCASE ANY UNDEFS.
BLT B,(Q) ;MOVE SYMBOLS
POP P,B ;GET NEW B
SUB B,HISTRT
ADD B,HVAL1
SOJ B, ;REMOVE CARRY
ADDI S,(B) ;SET UP JOBUSY
BLTSY1: MOVE Q,JOBREL
SUB Q,HISTRT
ADD Q,HVAL1
SUBI Q,1 ;ONE TOO HIGH
MOVEM Q,HVAL
JRST NODDT
NOBLT: HRRZ Q,HILOW ;GET HIGHEST LOC LOADED
HRRZ A,S ;GET BOTTOM OF UNDF SYMBOLS
SUB A,KORSP ;DON'T FORGET PATCH SPACE
IORI A,1777 ;MAKE INTO A K BOUND
IORI Q,1777
CAIN A,(Q) ;ARE THEY IN SAME K
IFN EXPAND,<JRST [PUSHJ P,XPAND>
PUSHJ P,MORCOR
IFN EXPAND,< JRST NOBLT]>
MOVEM Q,HISTRT ;SAVE AS START OF HIGH
MOVEI A,400000 ;HISEG ORIGIN
MOVEM A,HVAL1 ;SAVE AS ORIGIN
SUB S,HISTRT ;GET POSITION OF UNDF POINTER
ADDI S,377777 ;RELATIVE TO ORG
SUB B,HISTRT ;SAME FOR SYM POINTER
ADDI B,377777
TRO F,SEENHI ;SO JOBHRL WILL BE SET UP
JRST BLTSY1 ;AND USE COMMON CODE
>
IFN DMNSW!LDAC,<
MORCOR: ERROR ,</MORE CORE NEEDED#/>
EXIT>
SUBTTL WRITE CHAIN FILES
IFE K,< ;DONT INCLUDE IN 1KLOAD
CHNC: SKIPA A,JOBCHN(X) ;CHAIN FROM BREAK OF FIRST BLOCK DATA
CHNR: HLR A,JOBCHN(X) ;CHAIN FROM BREAK OF FIRST F4 PROG
IFN ALGSW,<TRNE F,ALGFL ;IF ALGOL LOADING
POPJ P, ;JUST RETURN>
HRRZS A ;ONLY RIGHT HALF IS SIGNIFICANT
JUMPE A,LD7C ;DON'T CHAIN IF ZERO
TLNN N,AUXSWI ;IS THERE AN AUX DEV?
JRST LD7D ;NO, DON'T CHAIN
PUSH P,A ;SAVE WHEREFROM TO CHAIN
JUMPE D,.+2 ;STARTING ADDR SPECIFIED?
HRRZM D,STADDR ;USE IT
CLOSE 2, ;INSURE END OF MAP FILE
TLZ N,AUXSWI+AUXSWE ;INSURE NO PRINTED OUTPUT
PUSHJ P,SASYM ;DO LIB SEARCH, SETUP JOBSA, ETC.
IFN RPGSW,<TLNE N,RPGF ;IF IN CCL MODE
TDZA W,W ;NO MESSAGES>
MOVE W,[SIXBIT ?CHAIN?] ;FINAL MESSAGE
PUSHJ P,BLTSET ;SETUP BLT PNTR, SETDDT, RELEAS
POP P,A ;GET WHEREFROM
HRRZ W,R ;CALCULATE MIN IOWD NECESSARY
SKIPE JOBDDT(X) ;IF JOBDDT KEEP SYMBOLS
CAILE W,1(S)
JRST CHNLW1
HRRZ W,JOBREL ;NEED SYMBOLS AND THEY HAVE NOT MOVED DOWN
SUBI W,(X) ;BECAUSE WE WILL NOT HAVE BLITTED
SUBI B,-1(X) ;SYMBOL TABLE WILL COME OUT IN A
MOVEM B,JOBSYM(X) ;DIFFERENT PLACE
CHNLW1: MOVNS W
ADDI W,-7(A)
ADDI A,-7(X)
PUSH A,W ;SAVE LENGTH
HRLI W,-1(A)
MOVSM W,IOWDPP ;...
SETZM IOWDPP+1 ;JUST IN CASE
PUSH A,JOBCHN(X)
PUSH A,JOBSA(X) ;SETUP SIX WORD TABLE
PUSH A,JOBSYM(X) ;...
PUSH A,JOB41(X)
PUSH A,JOBDDT(X)
SETSTS 2,17 ;SET AUX DEV TO DUMP MODE
MOVSI W,435056 ;USE .CHN AS EXTENSION
MOVEM W,DTOUT1 ;...
PUSHJ P,IAD2 ;DO THE ENTER
OUTPUT 2,IOWDPP ;WRITE THE CHAIN FILE
STATZ 2,IOBAD!IODEND
JRST LOSEBIG
CLOSE 2,
STATZ 2,IOBAD!IODEND
IFN RPGSW,<JRST LOSEBIG
TLNE N,RPGF ;IF IN CCL MODE
JRST CCLCHN ;LOAD NEXT LINK
EXIT>
LOSEBI: TTCALL 3,[ASCIZ /?DEVICE ERROR/]
EXIT>
SUBTTL SPECIAL CHAINB
IFE SPCHN,< XLIST >
IFN SPCHN,<
CHNBG:
PUSHJ P,FSCN1A ;FORCE SCAN TO COMPLETION FOR CURRENT FILE
TLNN N,AUXSWI ;IS THERE AN AUX DEV??
JRST LD7D
HRLZI W,-1(R) ;CHNTAB-L = ADDRESS OF VECTOR TABLE
HRRI W,1 ;CHNTAB-R = NEXT DISK BLOCK TO RITE INTO
MOVEM W,CHNTAB
MOVE C,[RADIX50 4,OVTAB] ;DEFINE GLOBAL SYMBOL OVTAB
MOVEI W,(R) ;TO HAVE VALUE THE BEGINNING OF THE VECTOR TABLE
PUSHJ P,SYMPT
ADDI R,VECLEN ;RESERVE SPACE FOR VECTOR TABLE
MOVE C,[RADIX50 4,OVBEG] ;OVBEG IS BEGINNING OF OVERLAY AREA
MOVEI W,(R)
PUSHJ P,SYMPT
HRRZM R,BEGOV ;AND SAVE IN OVBEG
OPEN 4,CHNOUT ;OPEN FILE FOR CHAIN
JRST ILD5 ;CANT OPEN CHAIN FILE
ENTER 4,CHNENT ;ENTER CHAIN FILE
JRST IMD3 ;NO CAN DO
HRRZ W,N
SUB W,HISTRT ;KEEP N RIGHT HALF AS RELATIVE TO HISTRT
HRRZM W,CHNACN ;SAVE FOR RESTORING
MOVEM B,CHNACB ;ALSO B R IS SAVED IN BEGOV
POPJ P,
CHNENS: TLOA N,PPCSW ;THIS FLAG UNUSED AT THIS POINT
CHNEN: TLZ N,PPCSW ;ON TO NOT DELETE NEW SYMBOLS
SKIPN CHNACB ;WILL BE NON-ZERO IF WE SAW A /< (> TO KEEP MACRO HAPPY)
JRST LD7D ;ERROR MESSAGE
PUSHJ P,FSCN1A ;LOAD LIB (IF DESIRED) AND FORCE SCAN
SKIPL Q,S ;CHECK SYMBOL TABLE FOR MISSED UNDEFS
JRST NOER ;NONE THERE
MOVEI E,0 ;COUNT OF ERRORS
ONCK:
IFN FAILSW,<SKIPL V,1(Q) ;IF HIGH ORDER BIT IS ON
TLNN V,740000 ;OR IF ALL CODE BITS 0
JRST NXTCK ;THEN NOT TO BE CHECKED>
MOVE V,2(Q) ;GET FIXUP WORD
TLNE V,100000 ;BIT INDICATES SYMBOL TABLE FIXUP
JRST SMTBFX
IFN FAILSW,<TLNE V,40000 ;BIT INDICATES POLISH FIXUP
JRST POLCK>
TLZE V,740000 ;THESE BITS WOULD MEAN ADDITIVE
JRST [JSP A,CORCKL
JRST NXTCK] ;ONLY TRY FIRST LOCATION
CORCK: JSP A,CORCKL
HRRZ V,@X ;THE WAY TO LINK
CORCKL: IFN REENT,<CAMGE V,HVAL1>
CAMGE V,BEGOV
SKIPA ;NOT IN BAD RANGE
JRST ERCK ;BAD, GIVE ERROR
JUMPE V,NXTCK ;CHAIN HAS RUN OUT
IFN REENT,<CAMGE V,HVAL1 ;GET CORRECT LINK
SKIPA X,LOWX
MOVE X,HIGHX>
XCT (A) ;TELLS US WHAT TO DO
JRST CORCKL ;GO ON WITH NEXT LINK
SMTBFX: TLNE N,PPCSW ;IF NOT CUTTING BACK SYMBOL TABLE
JRST NXTCK ;THE ALL OK
ADD V,HISTRT ;GET PLACE TO POINT TO
HRRZS V
HLRE D,CHNACB ;OLD LENGTH OF TABLE (NEGATIVE)
HLRE T,B ;NEW LENGTH
SUB D,T ;-OLD LEN+NEW LEN
ADDI D,(B) ;OLD BOTTOM=NEW BOTTOM+NEW LEN-OLD LEN
CAIG V,(D) ;IS IT IN THE PART WE ARE KEEPING
JRST ERCK
JRST NXTCK ;YES
IFN FAILSW,<POLCK: HLRZ C,V ;FIND HEADER
PUSHJ P,SREQ
SKIPA
JRST LOAD4A ;SHOULD BE THERE
HRL C,2(A) ;NOW FIRST OPERATOR (STORE)
MOVSS C
PUSHJ P,SREQ
SKIPA
JRST LOAD4A
ANDI C,37 ;GET OPERATION
HRRZ V,2(A) ;DESTINATION
JRST @CKSMTB-15(C) ;DISPATCH
CKSMTB: EXP SMTBFX,SMTBFX,SMTBFX,CORCK,LCORCK,CORCK,NXTCK
LCORCK: JSP A,CORCKL
HLRZ V,@X>
ERCK: MOVE C,1(Q) ;GET SYMBOL NAME
PUSHJ P,FCRLF ;FORCE CRLF AND OUTPUT ON TTY
PUSHJ P,PRNAME ;PRINT IT
ADDI E,1 ;MARK ERROR
NXTCK: ADD Q,SE3 ;TRY ANOTHER
JUMPL Q,ONCK
IFN REENT,<PUSHJ P,RESTRX ;GET PROPER X BACK>
JUMPE E,NOER ;DID ANYTHING GO WRONG??
ERROR ,</UNDEFINED GLOBAL(S) IN LINK@/>
JRST LD2 ;GIVE UP
NOER: MOVE A,BEGOV ;GET START OF OVERLAY
ADDI A,(X) ;GET ACTUAL CURRENT LOCATION
IFN REENT,<HRRZ W,HILOW ;AND END OF OVERLAY+1
HRRZM A,HILOW ;RESET>
IFE REENT,<HRRZ W,R
ADDI R,(X) ;A GOOD GUESS>
SUBM A,W ;W=-LENGTH
SUBI A,1 ;SET TO BASE-1 (FOR IOWD)
HRL A,W ;GET COUNT
MOVEM A,IOWDPP
HRR A,CHNTAB ;BLOCK WE ARE WRITING ON
HLRZ V,CHNTAB ;POINTER TO SEGMENT TABLE
ADDI V,1 ;NEXT LOCATION
HRLM V,CHNTAB ;REMEMBER IT
CAML V,BEGOV ;CHECK FOR OVERRUN
JRST [ERROR </?TOO MANY LINKS@/>
JRST LD2];GIVE UP
MOVEM A,@X ;PUT INTO TABLE
MOVN W,W ;GET POSITIVE LENGTH
ADDI W,DSKBLK-1
IDIVI W,DSKBLK ;GET NUMBER OF BLOCKS
ADDM W,CHNTAB ;AND UPDATE
TLZE N,PPCSW
JRST NOMVB ;DO NOT ADJUST SYMBOLS
HLRE W,CHNACB ;GET OLD LENGTH OF DEF SYMBOLS
HLRE C,B ;AND NEW LENGTH
SUB W,C ;-OLD LEN+NEW LEN
HRRZ C,B ;SAVE POINTER TO CURRENT S
ADD S,W
HRL W,W
ADD B,W ;UPDATE B (COUNT AND LOC)
JUMPGE S,UNLNKD ;JUST IN CASE NOTHING TO MOVE
HRRZ A,B ;PLACE TO PUT UNDEFS
UNLNK: MOVE W,(C)
MOVEM W,(A) ;TRANSFER
SUBI A,1
CAIE A,(S) ;HAVE WE MOVED LAST WORD??
SOJA C,UNLNK ;NO, CONTINUE
UNLNKD: HRRZ W,CHNACN ;GET SAVED N
ADD W,HISTRT
HRR N,W ;AND RESET IT
NOMVB: HRR R,BEGOV ;PICK UP BASE OF AREA
OUTPUT 4,IOWDPP ;DUMP IT
STATZ 4,IOBAD!IODEND ;AND ERROR CHECK
JRST LOSEBI
HRRZ V,R ;GET AREA TO ZERO
MOVEI W,@X
CAIL W,1(S) ;MUST MAKE SURE SOME THERE
POPJ P, ;DONE
SETZM (W)
CAIL W,(S)
POPJ P,
HRLS W
ADDI W,1
BLT W,(S) ;ZERO WORLD
POPJ P,
>
LIST
SUBTTL EXPAND CORE
IFN EXPAND,<
XPAND: TLNE F,FULLSW ;IF CORE EXCEEDED
POPJ P, ;DON'T WASTE TIME ON CORE UUO
PUSH P,Q
HRRZ Q,JOBREL
ADDI Q,2000
XPAND1: PUSH P,H ;GET SOME REGISTERS TO USE
PUSH P,X
PUSH P,N
PUSH P,JOBREL ;SAVE PREVIOUS SIZE
CAMG Q,ALWCOR ;CHECK TO SEE IF RUNNING OVER
CORE Q,
JRST XPAND6
IFE K,< HRRZ H,MLTP ;GET LOWEST LOCATION
TLNN N,F4SW ;IS FORTRAN LOADING>
MOVEI H,1(S) ;NO, USE S
POP P,X ;LAST JOBREL
HRRZ Q,JOBREL;NEW JOBREL
SUBI Q,(X) ;GET DIFFERENCE
HRLI Q,X ;PUT X IN INDEX FIELD
XPAND2: MOVE N,(X)
MOVEM N,@Q
CAMLE X,H ;TEST FOR END
SOJA X,XPAND2
HRLI H,-1(Q)
TLC H,-1 ;MAKE IT NEGATIVE
SETZM (H) ;ZERO NEW CORE
AOBJN H,.-1
MOVEI H,(Q)
XPAND8: ADD S,H
ADD B,H
ADDM H,HISTRT ;UPDATE START OF HISEG
IFN REENT,<ADDM H,HIGHX ;AND STORE LOCATION
TLNE F,HIPROG
ADDM H,-1(P) ;X IS CURRENTLY IN THE STACK>
POP P,N
ADD N,H
IFE K,< TLNN N,F4SW ;F4?
JRST XPAND3
ADDM H,PLTP
ADDM H,BITP
ADDM H,SDSTP
ADDM H,MLTP
TLNE N,SYDAT
ADDM H,V>
XPAND3: AOSA -3(P)
XPAND5: POP P,N
POP P,X
POP P,H
POP P,Q
POPJ P,
XPAND6: POP P,A ;CLEAR JOBREL OUT OF STACK
ERROR ,</MORE CORE NEEDED#/>
JRST XPAND5
XPAND7: PUSHJ P,XPAND
JRST SFULLC
JRST POPJM2
XPAND9: PUSH P,Q ;SAVE Q
HRRZ Q,JOBREL ;GET CORE SIZE
ADDI Q,(V) ;ADD XTRA NEEDED
JRST XPAND1 ;AND JOIN COMMON CODE
POPJM3: SOS (P) ;POPJ TO CALL-2
POPJM2: SOS (P) ;POPJ TO CALL-1
SOS (P) ;SAME AS POPJ TO
POPJ P, ;NORMAL POPJ MINUS TWO
>
SUBTTL SWITCH HANDLING
;ENTER SWITCH MODE
LD6A: CAIN T,57 ;WAS CHAR A SLASH?
TLO N,SLASH ;REMEBER THAT
LD6A2: TLO F,SSW ;ENTER SWITCH MODE
LD6A1: SETZB D,C ;ZERO TWO REGS FOR DECIMAL AND OCTAL
JRST LD3 ;EAT A SWITCH
;ALPHABETIC CHARACTER, SWITCH MODE
LD6:
CAIL T,141 ;ACCEPT LOWER CASE SWITCHES
SUBI T,40
IFN SPCHN!STANSW,<XCT LD6B-74(T) ;EXECUTE SWITCH FUNCTION>
IFE SPCHN!STANSW,<XCT LD6B-101(T) ;EXECUTE SWITCH FUNCTION>
TLZE N,SLASH ;SWITCH MODE ENTERED W/ SLASH?
JRST LD6D ;LEAVE SWITCH MODE
JRST LD6A1 ;STAY IN SWITCH MODE
;DISPATCH TABLE FOR SWITCHES
; THE INSTRUCTION AT THE CHARACTER LOCATION IS EXECUTED
LD6B:
IFN SPCHN,<PUSHJ P,CHNBG ;LESS THAN - BEGINNING OF OVERLAY
PUSHJ P,CHNENS ;= - PUT OUT CHAIN RETAINING SYMBOLS
PUSHJ P,CHNEN ;GREATER THAN - END OF OVERLAY
JRST LD7B ;? - ERROR
JRST LD7B ;@ - ERROR>
IFG STANSW-SPCHN,<PUSHJ P,HSET ;< BECOMES H
JRST LD7B
PUSHJ P,VSWTCH ;> BECOMES V
JRST LD7B
JRST LD7B>
COMMENT/
AT STANFORD MAP SWITCHES < TO H
AND > TO V (THIS WILL BE OVERRIDDEN IF SOMEONE TRIES SPCHN=1)
WHAT A CROCK: FW/
PUSHJ P,ASWTCH ;A - LIST ALL GLOBALS
IFN DMNSW,<PUSHJ P,DMN2 ;B - BLOCKS DOWN SYMBOL TABLE >
IFE DMNSW,<JRST LD7B ;B - ERROR>
IFE K,< PUSHJ P,CHNC ;C - CHAIN, START W/ COMMON>
IFN K,< JRST LD7B ;C - ILLEGAL IN 1KLOAD>
PUSHJ P,LDDT ;D - DEBUG OPTION, LOAD DDT
TLO N,EXEQSW ;E - LOAD AND GO
PUSHJ P,LIBF ;F - LIBRARY SEARCH
PUSHJ P,LD5E ;G - GO INTO EXECUTION
IFE STANSW,<IFN REENT,< PUSHJ P,HSET ;H - REENTRANT. PROGRAM>
IFE REENT,<JFCL ;NOT REENT AND NOT STANFORD>>
IFN STANSW,<PUSHJ P,LDDTQX ;H - LOAD AND START RAID>
PUSHJ P,ISWTCH ;I - IGNORE STARTING ADDRESSES
TLZ N,ISAFLG ;J - USE STARTING ADDRESSES
IFE KUTSW,<JRST LD7B ;K - ERROR>
IFN KUTSW,<MOVEM C,CORSZ ;K - SET DESIRED CORE SIZE>
PUSHJ P,LSWTCH ;L - ENTER LIBRARY SEARCH
PUSHJ P,PRMAP ;M - PRINT STORAGE MAP
TLZ F,LIBSW+SKIPSW ;N - LEAVE LIBRARY SEARCH
HRR R,D ;O - NEW PROGRAM ORIGIN
PUSHJ P,PSWTCH ;P - PREVENT AUTO. LIB. SEARCH
TLZ F,NSW ;Q - ALLOW AUTO. LIB. SEARCH
IFE K,< PUSHJ P,CHNR ;R - CHAIN, START W/ RESIDENT>
IFN K,< JRST LD7B ;R - ILLEGAL IN 1KLOAD>
PUSHJ P,SSWTCH ;S - LOAD WITH SYMBOLS
PUSHJ P,LDDTX ;T - LOAD AND GO TO DDT
PUSHJ P,PMS ;U - PRINT UNDEFINED LIST
IFE STANSW,<IFN REENT,<PUSHJ P,VSWTCH ;V - LOAD REENTRANT LIB40>
IFE REENT,<JRST LD7B ;V -NO REENT, NO STANFORD: ERROR>>
IFN STANSW,<PUSHJ P,LDDTQ ;V - LOAD RAID>
TLZ F,SYMSW+RMSMSW ;W - LOAD WITHOUT SYMBOLS
TLZ N,ALLFLG ;X - DO NOT LIST ALL GLOBALS
IFE SAILSW,<
TLO F,REWSW ;Y - REWIND BEFORE USE
>
IFN SAILSW,<
PUSHJ P,SEGLOD ;Y - LOAD SYS:SAILOW FOR 2-SGMT SAIL
>
JRST LDRSTR ;Z - RESTART LOADER
; PAIRED SWITCHES ( +,-)
ASWTCH: JUMPL D,.+2 ;SKIP IF /-A
TLOA N,ALLFLG ;LIST ALL GLOBALS
TLZ N,ALLFLG ;DON'T
POPJ P,
ISWTCH: JUMPL D,.+2 ;SKIP IF /-I
TLOA N,ISAFLG ;IGNORE STARTING ADDRESSES
TLZ N,ISAFLG ;DON'T
POPJ P,
LSWTCH: JUMPL D,.+2 ;SKIP IF /-L
TLOA F,LIBSW!SKIPSW ;ENTER LIBRARY SEARCH
TLZ F,LIBSW!SKIPSW ;DON'T
POPJ P,
PSWTCH: JUMPL D,.+2 ;SKIP IF /-P
TLOA F,NSW ;PREVENT AUTO. LIB SEARCH
TLZ F,NSW ;ALLOW
POPJ P,
SSWTCH: JUMPL D,.+2 ;SKIP IF /-S
TLOA F,SYMSW!RMSMSW ;LOAD WITH SYMBOLS
TLZ F,SYMSW!RMSMSW ;DON'T
POPJ P,
IFN REENT,<
VSWTCH: JUMPL D,.+2 ;SKIP IF /-V
TROA F,VFLG ;SEARCH RE-ENTRANT LIBRARY
TRZ F,VFLG ;DON'T
POPJ P,>
IFN SAILSW,<
SEGLOD: PUSHJ P,FSCN1 ;FORCE SCAN TO COMPLETION
HRRZ W,R ;CHECK LEGAL
CAILE W,140 ; (MUST BE NOTHING LOADED EARLIER)
JRST [ERROR ,<./Y MUST APPEAR BEFORE ANY FILES ARE LOADED`.>
JRST LD2] ;TRY AGAIN
MOVE W,[SIXBIT /SAILOW/] ;WILL LOAD SAILOW NOW
ADD W,D ;SAILOW, SAILOX, SAILOY, DEPENDING
;ON ARG -- W FOR SAIL, X FOR OSAIL, Y FOR NSAIL
TLZ F,SYMSW!RMSMSW ;SET SWITCHES (SEE LDDT)
PUSHJ P,LDDT1 ;SET SYS AS DEVICE, PREPARE
PUSHJ P,LDF ;LOAD SAILOW
POPJ P, ;AFRAID OF `JRST LDF'
>; END OF SEGMENT LOADING OPTION
IFN REENT,<
; H SWITCH --- EITHER /H OR /NH
HSET: JUMPE D,SETNUM ;/H ALWAYS LEGAL
CAIGE D,2 ;WANT TO CHANGE SEGMENTS
JRST SETSEG ;YES,GO DO IT
TRNN F,SEENHI ;STARTED TO LOAD YET?
JRST HCONT ;NO, CONTINUE.
ERROR ,<?/H ILLEGAL AFTER FIRST HISEG FILE IS LOADED@?>>
LDRSTR: ERROR 0,</LOADER RESTARTED@/>
JRST LD ;START AGAIN
IFN REENT,<
REMPFL: ERROR ,</?LOADER REMAP FAILURE@/>
JRST LDRSTR
HCONT: HRRZ C,D
ANDCMI C,1777
CAIL C,400000
CAIG C,(H)
JRST COROVL ;BEING SET LOWER THEN 400000 OR MORE THAN TO OF LOW SEG
HRRZM C,HVAL1 ;WE HAVE REMOVED THE ODD BITS TO MAKE A 1K MULT
ADDI C,JOBHDA
CAILE C,(D) ;MAKE SURE OF ENOUGH ROOM
MOVE D,C
HRLI D,W ;SET UP W IN LEFT HALF
MOVEM D,HVAL
POPJ P, ;RETURN.
COROVL: ERROR ,</HISEG STARTING ADDRESS TOO LOW@/>
JRST LDRSTR
SETNUM: TRO F,NOHI ;SET NO-HIGH-SEG SWITCH.
POPJ P,>
;SWITCH MODE NUMERIC ARGUMENT
LD6C: LSH D,3 ;BUILD OCTAL NUMERIC ARGUMENT
ADDI D,-60(T)
IMULI C,↑D10
ADDI C,-"0"(T) ;ACCUMULATE DEC AND OCTAL
JRST LD3
;EXIT FROM SWITCH MODE
LD6D: TLZ F,SSW ;CLEAR SWITCH MODE FLAG
TLNE F,FSW ;TEST FORCED SCAN FLAG
JRST LD2D ;SCAN FORCED, START NEW IDENT.
JRST LD3 ;SCAN NOT FORCED, USE PREV IDENT
;ILLEGAL CHARACTER, NORMAL MODE
LD7: IFN SYMARG,<
CAIN T,"#" ;DEFINING THIS SYMBOL
JRST DEFINE ;YES
TRNN F,ARGFL ;TREAT AS SPECIAL
JRST .+4 ;NO
CAIE T,"$"
CAIN T,"%"
JRST LD4 ;YES>
CAIN T,"Z"-100 ;TEST FOR ↑Z
JRST LD5E1 ;TREAT AS ALTMODE FOR BATCH
ERROR 8,</CHAR.%/>
JRST LD2 ;TRY TO CONTINUE
;SYNTAX ERROR, NORMAL MODE
LD7A: ERROR 8,</SYNTAX%/>
JRST LD2
;ILLEGAL CHARACTER, SWITCH MODE
LD7B: CAIN T,"-" ;SPECIAL CHECK FOR -
JRST [SETOB C,D
JRST LD3]
CAIN T,"Z"-100 ;CHECK FOR /↑Z
JRST LD5E1 ;SAME AS ↑Z
ERROR 8,</SWITCH%/>
JRST LD2
;ATTEMPT TO CHAIN WITH SPECIFIED HALF OF JOBCHN = 0
IFE K,<
LD7C: ERROR ,<?UNCHAINABLE AS LOADED@?>
JRST LD2
;ATTEMP TO CHAIN WITHOUT SPECIFYING DEVICE
LD7D: ERROR ,<?NO CHAIN DEVICE@?>
JRST LD2>
IFN DMNSW,<
DMN2:
IFN ALGSW,<TRNE F,ALGFL ;IF LOADING ALGOL
POPJ P, ;JUST RETURN>
CAIN D,1 ;SPECIAL CASE
TROA F,HISYM ;YES ,BLT SYMBOLS INTO HISEG
JUMPL D,.+2
TROA F,DMNFLG ;TURN ON /B
IFN KUTSW,<TRZA F,DMNFLG ;TURN OFF IF /-B
SETZM CORSZ ;SET TO CUT BACK CORE>
IFE KUTSW,<TRZ F,DMNFLG ;TURN OFF IF /-B>
CAMLE D,KORSP
MOVEM D,KORSP
POPJ P, ;RETURN>
SUBTTL CHARACTER CLASSIFICATION TABLE DESCRIPTION:
; EACH CHARACTER HAS ASSOCIATED WITH IT A FOUR BIT BYTE
; PACKED IN THE CHARACTER CLASSIFICATION TABLE. THE CHARACTER
; CLASSIFICATION CODES ARE ORDERED IN SUCH A WAY AS TO GIVE
; DELIMITERS OF HIGHER PRECEDENCE LOWER CLASSIFICATION NUMBERS.
; CERTAIN CHARACTERS HAVE NO EFFECT ON THE COMMAND STRING, AND
; THEREFORE DO NOT EFFECT ORDERING OF DELIMITERS. FOUR CODES
; ARE RESERVED FOR ALTERNATE DISPATCHES WHILE THE SWITCH MODE IS
; IN EFFECT.
;CLASSIFICATION BYTE CODES:
; BYTE DISP CLASSIFICATION
; 00 - 00 ILLEGAL CHARACTER, SWITCH MODE
; 01 - 01 ALPHABETIC CHARACTER, SWITCH MODE
; 02 - 02 NUMERIC CHARACTER, SWITCH MODE
; 03 - 03 SWITCH MODE ESCAPE, SWITCH MODE
; 00 - 04 ILLEGAL CHARACTER, NORMAL MODE
; 01 - 05 ALPHABETIC CHARACTER, NORMAL MODE
; 02 - 06 NUMERIC CHARACTER, NORMAL MODE
; 03 - 07 SWITCH MODE ESCAPE, NORMAL MODE
; 04 - 10 IGNORED CHARACTER
; 05 - 11 ENTER SWITCH MODE CHARACTER
; 06 - 12 DEVICE IDENTIFIER DELIMITER
; 07 - 13 FILE EXTENSION DELIMITER
; 10 - 14 OUTPUT SPECIFICATION DELIMITER
; 11 - 15 INPUT SPECIFICATION DELIMITER
; 12 - 16 LINE TERMINATION
; 13 - 17 JOB TERMINATION
;BYTE POINTERS TO CHARACTER CLASSIFICATION TABLE
LD8: POINT 4,LD9(Q),3
POINT 4,LD9(Q),7
POINT 4,LD9(Q),11
POINT 4,LD9(Q),15
POINT 4,LD9(Q),19
POINT 4,LD9(Q),23
POINT 4,LD9(Q),27
POINT 4,LD9(Q),31
POINT 4,LD9(Q),35
;CHARACTER CLASSIFICATION TABLE
LD9: BYTE (4)4,0,0,0,0,0,0,0,0
BYTE (4)4,4,4,4,12,0,0,0,0
BYTE (4)0,0,0,0,0,0,0,0,0
BYTE (4)13,0,0,0,0,4,0,4,0
IFE SYMARG,< BYTE (4)0,0,0,0,5,3,0,0,11>
IFN SYMARG,< BYTE (4)0,0,14,0,5,3,0,0,11>
BYTE (4)0,7,5,2,2,2,2,2,2
IFE SPCHN!STANSW,< BYTE (4)2,2,2,2,6,0,0,10,0>
IFN SPCHN!STANSW,< BYTE (4)2,2,2,2,6,0,1,10,1>
IFE RPGSW,< BYTE (4)0,0,1,1,1,1,1,1,1>
IFN RPGSW,< BYTE (4) 0,10,1,1,1,1,1,1,1>
BYTE (4)1,1,1,1,1,1,1,1,1
BYTE (4)1,1,1,1,1,1,1,1,1
IFE PP,<BYTE (4)1,0,0,0,0,10,0,1,1>
IFN PP,<BYTE (4)1,10,0,10,0,10,0,1,1>
BYTE (4)1,1,1,1,1,1,1,1,1
BYTE (4)1,1,1,1,1,1,1,1,1
BYTE (4)1,1,1,1,1,1,0,0,13
BYTE (4)13,4
SUBTTL INITIALIZE LOADING OF A FILE
ILD: MOVEI W,BUF1 ;LOAD BUFFER ORIGIN
MOVEM W,JOBFF
TLOE F,ISW ;SKIP IF INIT REQUIRED
JRST ILD6 ;DONT DO INIT
ILD7: OPEN 1,OPEN3 ;KEEP IT PURE
JRST ILD5B
ILD6: TLZE F,REWSW ;SKIP IF NO REWIND
MTAPE 1,1 ;REWIND
ILD2: LOOKUP 1,DTIN ;LOOK UP FILE FROM DIRECTORY
JRST ILD3 ;FILE NOT IN DIRECTORY
IFE LNSSW,<
IFE K,< INBUF 1,2 ;SET UP BUFFERS>
IFN K,< INBUF 1,1 ;SET UP BUFFER>>
IFN LNSSW,<INBUF 1,1
MOVEI W,BUF1
EXCH W,JOBFF
SUBI W,BUF1
IFE K,<MOVEI C,4*203+1>
IFN K,<MOVEI C,203+1>
IDIV C,W
INBUF 1,(C)>
TLO F,ASW ;SET LEFT ARROW ILLEGAL FLAG
TLZ F,ESW ;CLEAR EXTENSION FLAG
POPJ P,
; LOOKUP FAILURE
ILD3: TLOE F,ESW ;SKIP IF .REL WAS ASSUMED
JRST ILD4 ;FATAL LOOKUP FAILURE
SETZM DTIN1 ;ZERO FILE EXTENSION
JRST ILD2 ;TRY AGAIN WITH NULL EXTENSION
ILD4: IFE REENT,<IFE TEN30,< ;PDP-6 ONLY
MOVE W,[SIXBIT /LIB40/]
CAME W,DTIN ;WAS THIS A TRY FOR LIB40?
JRST ILD4A ;NO
TRZ W,(SIXBIT / 0/) ;YES
MOVEM W,DTIN ;TRY LIB4
PUSHJ P,LDDT2 ;USE .REL EXTENSION
TLZ F,ESW ;...
JRST ILD2 ;GO TRY AGAIN
ILD4A:>>
IFN PP,<MOVSI W,(SIXBIT /DSK/)
CAMN W,ILD1 ;TRIED DSK ONCE?
JRST ILD9 ;YES, FILE DOES NOT EXIST
MOVEM W,ILD1 ;SET IT UP
SETZM PPN ;CLEAR OLD VALUE
PUSHJ P,LDDT2 ;SET UP .REL
TLZ F,ESW ;SO WE CAN TRY BLANK EXT
JRST ILD7 ;OPEN DSK,TRY AGAIN>
ILD9: ERROR ,</CANNOT FIND#/>
JRST LD2
; DEVICE SELECTION ERROR
ILD5A: SKIPA W,LD5C1
ILD5B: MOVE W,ILD1
ILD5: TLO F,FCONSW ;INSURE TTY OUTPUT
PUSHJ P,PRQ ;START W/ ?
PUSHJ P,PWORD ;PRINT DEVICE NAME
ERROR 7,</UNAVAILABLE@/>
JRST LD2
SUBTTL LIBRARY SEARCH CONTROL AND LOADER CONTROL
;LIBF ENABLES A LIBRARY SEARCH OF <SYS:LIB4.REL>
LIBF: PUSHJ P,FSCN1 ;FORCE SCAN TO COMPLETION
PUSH P,ILD1 ;SAVE DEVICE NAME
PUSHJ P,LIBF1 ;LOAD SYS:JOBDAT.REL
IFN SAILSW,<LIBAGN: PUSHJ P,SALOAD ;LOAD RELS AND SEARCH LIBS>
IFN REENT,<TRNN F,SEENHI ;IF ANY HISEG LOADED NO RE-ENT OP SYSTEM
TRNN F,VFLG
JRST LIBF3
IFN ALGSW,<TRNE F,ALGFL ;SPECIAL ACTION IF LOADING ALGOL
JRST [MOVE C,[RADIX50 44,%ALGDR]
MOVEI W,400010 ;JOBHDA
PUSHJ P,SYMPT ;DEFINE IT
JRST LIBF3] ;DON'T LOAD IMP40>
MOVE W,[SIXBIT /IMP40/]
PUSHJ P,LIBF2
LIBF3:>
TRNN F,COBFL ;COBOL SEEN?
SKIPA W,[SIXBIT /LIB40/] ;FIRST TRY AT NAME
MOVE W,[SIXBIT /LIBOL/] ;YES, SEARCH COBOL'S LIBRARY ONLY
PUSHJ P,LIBF2 ;LOAD SYS:LIB40.REL
IFN SAILSW,<MOVE W,LIBPNT ;SEE IF ANY MORE TO DO
CAME W,[XWD -RELLEN-1,LIBFLS-1]
JRST LIBAGN
MOVE W,PRGPNT ;IT COULD BE DANGEROUS TO LOAD PROGRAMS HERE
CAME W,[XWD -RELLEN-1,PRGFLS-1]
JRST LIBAGN ;MORE TO DO, TRY AGAIN>
POP P,ILD1 ;CALL TO LDDT1 WILL PUT IT IN OLDDEV
LIBF1: MOVE W,[SIXBIT /JOBDAT/] ;LOAD SYS:JOBDAT.REL
LIBF2: PUSHJ P,LDDT1
LIBGO: JUMPGE S,EOF2 ;JUMP IF NO UNDEFINED GLOBALS
TLO F,SLIBSW+SKIPSW ;ENABLE LIBRARY SEARCH
TLZ F,SYMSW ;DISABLE LOADING WITH SYMBOLS
JRST LDF ;INITIALIZE LOADING LIB4
; LIB CONTROLS THE LIBRARY SEARCH OF ONE FILE
LIB: JUMPGE S,EOF1 ;JUMP IF NO UNDEFINED GLOBALS
TLO F,SKIPSW ;SET SKIPSW TO IGNORE MODE
IFN DIDAL,<TRNE F,XFLG ;INDEX IN CORE?
JRST INDEX1 ;YES>
JRST LOAD ;CONTINUE LIB. SEARCH
LIB1: CAIE A,4 ;TEST FOR ENTRY BLOCK
JRST LIB29 ;NOT AN ENTRY BLOCK, IGNORE IT
LIB2: PUSHJ P,RWORD ;READ ONE DATA WORD
MOVE C,W
TLO C,040000 ;SET CODE BITS FOR SEARCH
PUSHJ P,SREQ
TLZA F,SKIPSW ;REQUEST MATCHES ENTRY, LOAD
JRST LIB2 ;NOT FOUND
LIB3: PUSHJ P,RWORD ;READ AND IGNORE ONE DATA WORD
JRST LIB3 ;LOOP TO IGNORE INPUT
LIB29:
IFN DIDAL,<CAIN A,14 ;INDEX BLOCK?
JRST INDEX0 ;YES>
LIB30: HRRZ C,W ;GET WORD COUNT
JUMPE C,LOAD1 ;IF NUL BLOCK RETURN
CAILE C,↑D18 ;ONLY ONE SUB-BLOCK
JRST LIB3 ;NO,SO USE OLD SLOW METHOD
AOJA C,LIB31 ;ONE FOR RELOCATION WORD
BLOCK0: HRRZ C,W ;GET WORD COUNT
JUMPE C,LOAD1 ;NOISE WORD
LIB31: CAML C,BUFR2 ;DOES BLOCK OVERLAP BUFFERS?
SOJA C,LIB32 ;YES,ALLOW FOR INITIAL ILDB
ADDM C,BUFR1 ;ADD TO BYTE POINTER
MOVNS C ;NEGATE
ADDM C,BUFR2 ;TO SUBTRACT C FROM WORD COUNT
JRST LOAD1 ;GET NEXT BLOCK
LIB32: SUB C,BUFR2 ;ACCOUNT FOR REST OF THIS BUFFER
PUSHJ P,WORD+1 ;GET ANOTHER BUFFERFUL
JRST LIB31 ;TRY AGAIN
IFN SAILSW,<
COMMENT * BLOCK TYPE 15 AND 16 USED TO SPECIFY PROGRAMS AND
LIBRARIES WHICH MUST BE LOADED (SEARCHED) IF THE PROGRAM
IN WHICH THE BLOCK APPEARS IS LOADED. IT IS NOW TIME TO
LOAD AND SEARCH THESE FILES. IF ANY MAKE REQUESTS, THEY ARE ADDED
TO THE END. WE WILL COME BACK AND LOOK AGAIN IN CASE A
LIBRARY PROGRAM LOAD A REL PROGRAM. ORIGINAL CODE BY DCS*
SALOAD: MOVE T,[XWD -RELLEN-1,PRGFLS-1] ;TO RESET WITH AT END
MOVEI D,PRGPNT ;OINTER TO UPPER LIMIT
PUSHJ P,PRGPRG ;LOAD THEM IF ANY
;NOW FOR LIBRARY SEARCH
MOVE T,[XWD -RELLEN-1,LIBFLS-1]
MOVEI D,LIBPNT
PRGPRG: MOVEM D,LODLIM# ;SAVE POINTER TO LIMIT
MOVEM T,LODSTP# ;START FOR RESETTING
PRGBAK: MOVEM T,LODPNT# ;AND START
CAMN T,@LODLIM ;GOTTEN TO END YET?
JRST PRGDON ;YES, DUMP IT
SKIPN W,PRGDEV(T) ;IS DEVICE SPECIFIED?
MOVSI W,(SIXBIT /DSK/) ;NO, DSK
MOVEM W,ILD1 ;WHERE WE INIT FROM
MOVSI W,(SIXBIT /REL/) ;EXTENSION
MOVEM W,DTIN1
MOVE W,PRGFIL(T)
MOVEM W,DTIN ;FILE NAME
MOVE W,PRGPPN(T) ;THE PROJECT PROG
MOVEM W,DTIN+3
PUSH P,JRPRG ;A RETURN ADDRESS
TLZ F,ISW ;FORCE NEW INIT
HRRZ T,LODLIM
CAIN T,LIBPNT ;WHICH ONE
JRST LIBGO
JRST LDF
PRGRET: MOVE T,LODPNT ;RETURNS HERE, GET NEXT ONE
AOBJN T,PRGBAK
PRGDON: MOVE T,LODSTP ;RESTE POINTER IN CASE MORE ON OTHER LIBS
MOVEM T,@LODLIM
JRPRG: POPJ P,PRGRET ;PUSHED TO GET A RETURN ADDRESS
PRGFIL==1 ;REL INDEX FOR FILE NAMES
PRGPPN==RELLEN+1 ;AND FOR PPNS
PRGDEV==2*RELLEN+1 ;AND FOR DEVICES
> ;END OF IFN SAILSW
SUBTTL LDDT LOADS <SYS:DDT.REL> AND SETS SYMSW
IFN STANSW,<
LDDTQX: TLO N,DDSW+EXEQSW ;WILL START RAID AFTER LOADING
LDDTQ: PUSH P,D ;SAVE ARG
PUSHJ P,FSCN1 ;SEE BELOW
MOVE W,['RAID '] ;LOAD RAID STATT DDT
IFN DMNSW,<SETZM (P);ELSE>POP P,D ;/0D FOR DMN2 (BELOW) !?!
JRST LDDT11 ;JOIN FORCES
>;IFN STANSW
LDDTX:
IFN ALGSW,<TRNE F,ALGSW
POPJ P,>
TLO N,DDSW+EXEQSW ;T - LOAD AND GO TO DDT
LDDT:
IFN ALGSW,<TRNE F,ALGFL
POPJ P,>
IFN DMNSW,< PUSH P,D ;SAVE INCASE /NNND >
PUSHJ P,FSCN1 ;FORCE SCAN TO COMPLETION
MOVSI W,444464 ;FILE IDENTIFIER <DDT>
LDDT11: TLZ F,SYMSW!RMSMSW ;DON'T LOAD DDT WITH LOCAL SYMBOLS
PUSHJ P,LDDT1
PUSHJ P,LDF ;LOAD <SYS:DDT.REL>
TLO F,SYMSW!RMSMSW ;ENABLE LOADING WITH SYMBOLS
IFN DMNSW,< POP P,D ;RESTORE D
JRST DMN2 ;MOVE SYMBOL TABLE >
IFE DMNSW,< POPJ P,>
LDDT1: MOVEM W,DTIN ;STORE FILE IDENTIFIER
IFN PP,<MOVE W,ILD1 ;SAVE OLD DEV
MOVEM W,OLDDEV>
MOVSI W,637163 ;DEVICE IDENTIFIER <SYS>
MOVEM W,ILD1 ;STORE DEVICE IDENTIFIER
TLZ F,ISW+LIBSW+SKIPSW+REWSW ;CLEAR OLD FLAGS
LDDT2: MOVSI W,624554 ;EXTENSION IDENTIFIER <.REL>
LDDT3: MOVEM W,DTIN1 ;STORE EXTENSION IDENTIFIER
LDDT4:IFN PP,<EXCH W,PPN ;GET PROJ-PROG #
MOVEM W,DTIN+3
EXCH W,PPN ;W MUST BE SAVED SINCE IT MAY BE USED LATER>
POPJ P,
SUBTTL EOF TERMINATES LOADING OF A FILE
EOF: MOVE P,PDSAV ;RESTORE PUSHDOWN POINTER
EOF1: TLZ F,SLIBSW!SKIPSW ;CLEAR ONE FILE LIB. SEARCH FLAG
IFN DIDAL,<TRZ F,XFLG!LSTLOD ;CLEAR DIDAL FLAGS>
EOF2: TLNE F,RMSMSW ;IF REMEMBER LOADING WITH SYMBOLS IS ON
TLO F,SYMSW ;THEN RESTORE SYMBOL LOADING STATE
POPJ P,
; FORCE SCAN TO COMPLETION, LOAD IF NECESSARY
FSCN: PUSHJ P,FSCN1 ;FORCED LOAD BEFORE TEST
TLNN F,FULLSW ;TEST FOR OVERLAP
POPJ P, ;NO OVERLAP, RETURN
MOVE W,H ;FETCH CORE SIZE REQUIRED
SUBI W,1(S) ; COMPUT DEFICIENCY
JUMPL W,EOF2 ;JUMP IF NO OVERLAP
TLO F,FCONSW ;INSURE TTY OUTPUT
PUSHJ P,PRQ ;START WITH ?
PUSHJ P,PRNUM0 ;INFORM USER
ERROR 7,</WORDS OF OVERLAP#/>
JRST LD2 ;ERROR RETURN
IFN SPCHN,<FSCN1A: TLNN F,NSW
PUSHJ P,LIBF>
FSCN1: TLON F,FSW ;SKIP IF NOT FIRST CALL TO FSCN
TLNN F,CSW+DSW+ESW ;TEST SCAN FOR COMPLETION
POPJ P,
FSCN2: PUSHJ P,LD5B1 ;STORE FILE OR EXTENSION IDENT.
; LOADER CONTROL, NORMAL MODE
LDF: PUSHJ P,ILD ;INITIALIZE LOADING
SUBTTL LOAD SUBROUTINE
LOAD: MOVEM P,PDSAV ;SAVE PUSHDOWN POINTER
IFN WFWSW,<SETZM VARLNG ;LENGTH OF VARIABLE AREA-ADDED TO RELOC>
IFN ALGSW,<SETZM OWNLNG ;LENGTH OF OWN AREA-ADDED TO RELOC>
IFN FAILSW,<SETZM LFTHSW ;RESET LOAD LEFT HALF FIXUP SW>
LOAD1: MOVE P,PDSAV ;RESTORE PUSHDOWN POINTER
LOAD1A: PUSHJ P,WORD ;INPUT BLOCK HEADER WORD
MOVNI E,400000(W) ;WORD COUNT - FROM RH OF HEADER
HLRZ A,W ;BLOCK TYPE - FROM LH OF HEADER
IFN FAILSW,<SKIPN POLSW ;ERROR IF STILL DOING POLISH>
CAIL A,DISPL*2 ;TEST BLOCK TYPE NUMBER
JRST LOAD4 ;ERROR, ILLEGAL BLOCK TYPE
TLNE F,SKIPSW ;BLOCK OK - TEST LOAD STATUS
JRST LIB1 ;RETURN TO LIB. SEARCH CONTROL
HRRZ T,LOAD2(A) ;LOAD RH DISPATCH ENTRY
CAIL A,DISPL ;SKIP IF CORRECT
HLRZ T,LOAD2-DISPL(A);LOAD LH DISPATCH ENTRY
TLNE F,FULLSW ;TEST CORE OVERLAP INDICATOR
SOJG A,HIGH0 ;IGNORE BLOCK IF NOT TYPE 1
JRST @T ;DISPATCH TO BLOCK SUBROUTINE
;DISPATCH TABLE - BLOCK TYPES
IFE FAILSW,<POLFIX==LOAD4A
LINK==LOAD4A>
IFE WFWSW,<LVARB==LOAD4A>
IFE DIDAL,<INDEX==LOAD4A>
IFE ALGSW!SAILSW,<ALGBLK==LOAD4A>
IFE SAILSW,<LDLIB==LOAD4A>
LOAD2: XWD LOCD, BLOCK0 ;10,,0
XWD POLFIX, PROG ;11,,1
XWD LINK, SYM ;12,,2
XWD LVARB, HISEG ;13,,3
XWD INDEX, LIB30 ;14,,4
XWD ALGBLK, HIGH ;15,,5
XWD LDLIB, NAME ;16,,6
XWD LOAD4A, START ;17,,7
DISPL==.-LOAD2
;ERROR EXIT FOR BAD HEADER WORDS
LOAD4: IFE K,<
CAIN A,400 ;FORTRAN FOUR BLOCK
JRST F4LD>
LOAD4A: MOVE W,A ;GET BLOCK TYPE
ERROR ,</ILL. FORMAT BLOCK TYPE !/>
PUSHJ P,PRNUM ;PRINT BLOCK TYPE
JRST ILC1 ;PRINT SUBROUTINE NAME
SUBTTL LOAD PROGRAMS AND DATA (BLOCK TYPE 1)
PROG: MOVEI V,-1(W) ;LOAD BLOCK LENGTH
PUSHJ P,RWORD ;READ BLOCK ORIGIN
ADD V,W ;COMPUTE NEW PROG. BREAK
IFN REENT,<TLNN F,HIPROG
JRST PROGLW ;NOT HIGH SEGMENT
PROG3: CAMGE W,HVAL1 ;CHECK TO SEE IF IN TOP SEG
JRST LOWCOR
MOVE T,JOBREL ;CHECK FOR OVERFLOW ON HIGH
CAIL T,@X
JRST PROG2
PUSHJ P,HIEXP
JRST FULLC
JRST PROG3>
PROGLW: MOVEI T,@X
CAMG H,T ;COMPARE WITH PREV. PROG. BREAK
MOVE H,T
TLNE F,FULLSW
JRST FULLC ;NO ERROR MESSAGE
IFN REENT,<CAML H,HVAL1
JRST COROVL ;WE HAVE OVERFLOWED THE LOW SEGMENT
CAMLE T,HILOW
MOVEM T,HILOW ;HIGHEST LOW CODE LOADED INTO>
CAILE H,1(S) ; SKIP IF SUFFICIENT CORE AVAILABLE
IFN EXPAND,<JRST [PUSHJ P,XPAND>
JRST FULLC
IFN REENT,< TLNE F,HIPROG
SUBI W,2000 ;HISEG LOADING LOW SEG>
IFN EXPAND,< JRST .-1]>
PROG2: MOVE V,W
PROG1: PUSHJ P,RWORD ;READ DATA WORD
IFN TEN30,<CAIN V,41 ;CHANGE FOR 10/30 JOBDAT
MOVEI V,JOB41 ;JOB41 IS DIFFERENT
CAIN V,74 ;SO IS JOBDAT
MOVEI V,JOBDDT>
IFN L,<CAML V,RINITL ;CHECK FOR BAD STORE>
MOVEM W,@X ;STORE DATA WORD IN PROG. AT LLC
AOJA V,PROG1 ;ADD ONE TO LOADER LOC. COUNTER
IFN REENT,<
LOWCOR: SUB V,HIGHX ;RELOC FOR PROPER
ADD V,LOWX ;LOADING OF LOW SEQMENT
SUB W,HIGHX
ADD W,LOWX
JRST PROGLW>
SUBTTL LOAD SYMBOLS (BLOCK TYPE 2)
SYM: PUSHJ P,PRWORD ;READ TWO DATA WORDS
PUSHJ P,SYMPT; PUT INTO TABLE
IFN REENT,<PUSHJ P,RESTRX>
JRST SYM
SYMPT: TLNE C,200000 ;GLOBAL REQUEST? WFW
JUMPL C,SYM3 ;CHECK FOR 60 NOT JUST HIGH BIT WFW
TLNN C,40000
JRST SYM1A ;LOCAL SYMBOL
TLNE C,100000
JRST SYM1B
PUSHJ P,SREQ ;GLOBAL DEF., SEARCH FOR REQUEST
JRST SYM2 ;REQUEST MATCHES
PUSHJ P,SDEF ;SEARCH FOR MULTIPLE DEFINITIONS
JRST SYM1 ;MULTIPLY DEFINED GLOBAL
JRST SYM1B
; PROCESS MULTIPLY DEFINED GLOBAL
SYM1: CAMN W,2(A) ;COMPARE NEW AND OLD VALUE
POPJ P,;
AOS MDG ;COUNT MULTIPLY DEFINED GLOBALS
PUSHJ P,PRQ ;START W/ ?
PUSHJ P,PRNAM ;PRINT SYMBOL AND VALUE
IFN RPGSW,<MOVE W,JOBERR ;RECORD THIS AS AN ERROR
ADDI W,1
HRRM W,JOBERR>
MOVE W,2(A) ;LOAD OLD VALUE
PUSHJ P,PRNUM ;PRINT OLD VALUE
ERROR 7,</MUL. DEF. GLOBAL IN PROG. !/>
MOVE C,SBRNAM ;GET PROGRAM NAME
PUSHJ P,PRNAME ;PRINT R-50 NAME
ERROR 0,</#/>
POPJ P, ;IGNORE MUL. DEF. GLOBAL SYM
; LOCAL SYMBOL
SYM1A: TLNN F,SYMSW ;SKIP IF LOAD LOCALS SWITCH ON
POPJ P,; IGNORE LOCAL SYMBOLS
SYM1B: CAIL H,(S) ;STORE DEFINED SYMBOL
IFN EXPAND,< PUSHJ P,XPAND7>
IFE EXPAND,< JRST SFULLC>
SYM1C: IFE K,<
TLNE N,F4SW; FORTRAN FOUR REQUIRES A BLT
PUSHJ P,MVDWN; OF THE TABLES>
MOVEI A,-2(S) ;LOAD A TO SAVE INST. AT SYM2
SYM1D: SUBI S,2; UPDATE UNDEFINED POINTER
POP B,2(A) ;MOVE UNDEFINED VALUE POINTER
POP B,1(A) ;MOVE UNDEFINED SYMBOL
MOVEM W,2(B) ;STORE VALUE
MOVEM C,1(B) ;STORE SYMBOL
POPJ P,
; GLOBAL DEFINITION MATCHES REQUEST
SYM2: PUSH P,SYM2C ;NEXT MUST BE A SUBROUTINE FOR LATER, SET RETURN
SYM2B: MOVE V,2(A) ;LOAD REQUEST POINTER
PUSHJ P,REMSYM
JUMPL V,SYM2W ;ADDITIVE REQUEST? WFW
PUSHJ P,SYM4A ;REPLACE CHAIN WITH DEFINITION
SYM2W1: PUSHJ P,SREQ ;LOOK FOR MORE REQUESTS FOR THIS SYMBOL
JRST SYM2B ;FOUND MORE
MOVE A,SVA ;RESTORE A
SYM2C: POPJ P,SYM1D ;RETURN, SEE SYM2 FOR USE OF ADDRESS
; REQUEST MATCHES GLOBAL DEFINITION
SYM2A: MOVE V,W ;LOAD POINTER TO CHAIN
MOVE W,2(A) ;LOAD VALUE
JUMPL V,FIXWP ;HANDLE ATTITIVE REQUEST WFW
JRST SYM4A
; PROCESS GLOBAL REQUEST
SYM3: TLNE C,040000; COMMON NAME
JRST SYM1B
TLC C,640000; PERMUTE BITS FROM 60 TO 04
PUSHJ P,SDEF ;SEARCH FOR GLOBAL DEFINITION
JRST SYM2A ;MATCHING GLOBAL DEFINITION
JUMPL W,SYM3X1 ;ADDITIVE FIXUP WFW
PUSHJ P,SREQ ;SEARCH FOR EXISTING REQUEST WFW
JRST SYM3A ;EXISTING REQUEST FOUND WFW
SYM3X1: TLNN W,100000 ;CHECK SYMBOL TABLE FIXUP
JRST SYM3X2 ;NO
MOVE V,1(B) ;MUST BE LAST SYMBOL DEFINED. GET SYMBOL
XOR V,W ;CHECK FOR IDENTITY
TDNE V,[XWD 77777,-1] ;BUT IGNORE HIGH 3 BITS
POPJ P, ;NOT SAME, ASSUME NOT LOADED LOCAL
HRRI W,2(B) ;GET LOCATION IN RIGHT HALF
TLO W,1
SUB W,HISTRT ;AND MAKE RELATIVE
IFN FAILSW,<TLZ W,040000>
SYM3X2: CAIL H,(S) ;STORE REQUEST IN UNDEF. TABLE WFW
IFN EXPAND,< PUSHJ P,XPAND7>
IFE EXPAND,< JRST SFULLC>
SYM3X: IFE K,<
TLNE N,F4SW; FORTRAN FOUR
PUSHJ P,MVDWN; ADJUST TABLES IF F4>
SUB S,SE3 ;ADVANCE UNDEFINED POINTER
MOVEM W,2(S) ;STORE UNDEFINED VALUE POINTER
MOVEM C,1(S) ;STORE UNDEFINED SYMBOL
POPJ P,;
; COMBINE TWO REQUEST CHAINS
SYM3A: SKIPL 2(A) ;IS IT ADDITIVE WFW
JRST SYM3A1 ;NO, PROCESS WFW
SYM3A4: PUSHJ P,SDEF2 ;YES, CONTINUE WFW
JRST SYM3A ;FOUND ANOTHER WFW
JRST SYM3X2 ;REALLY NO CHAIN THERE WFW
SYM3A1: SKIPE V,2(A) ;IF ADDRESS OF CHAIN IS 0, THROW IT AWAY
JRST SYM3A2 ;AND USE THE NEW ONE, ELSE ADD THE CHAINS
MOVEM W,2(A) ;W IS ADDRESS OF NEW CHAIN,STORE ON TOP OF OLD 0
POPJ P,
SYM3A2:
SYM3A3: MOVE A,2(A)
SYM3B: HRRZ V,A
IFN L,<CAMGE V,RINITL
HALT>
IFN REENT,<CAMGE V,HVAL1
SKIPA X,LOWX
MOVE X,HIGHX>
HRRZ A,@X ; LOAD NEXT ADDRESS IN CHAIN
JUMPN A,SYM3B ; JUMP IF NOT THE LAST ADDR. IN CHAIN
HRRM W,@X ;COMBINE CHAINS
POPJ P,;
;WFW PATCH FOR ADDITIVE GLOBAL REQUESTS
FIXWP: TLNN V,100000 ;CHECK FOR SYMBOL TABLE FIXUP
JRST FIXW
MOVE T,1(B) ;SYMBOL FIXUP, MUST BE LAST SYMBOL DEFINED
XOR T,V ;CHECK FO SAME
TDNE T,[XWD 77777,-1] ;EXCEPT FOR HIGH CODE BITS
POPJ P, ;ASSUME NON-LOADED LOCAL
HRRI V,2(B) ;GET LOCATION
SUBI V,(X) ;SO WE CAN USE @X
JRST FIXW1
FIXW: IFN REENT,<HRRZ T,V
CAMGE T,HVAL1
SKIPA X,LOWX
MOVE X,HIGHX>
IFN L,< HRRZ T,V
CAMGE R,RINITL
POPJ P,>
FIXW1: TLNE V,200000 ;IS IT LEFT HALF
JRST FIXWL
MOVE T,@X ;GET WORD
ADD T,W ;VALUE OF GLOBAL
HRRM T,@X ;FIX WITHOUT CARRY
MOVSI D,200000 ;SET UP TO REMOVE DEFERED INTERNAL IF THERE
JRST SYMFIX
FIXWL: HRLZ T,W ;UPDATE VALUE OF LEFT HALF
ADDM T,@X ;BY VALUE OF GLOBAL
MOVSI D,400000 ;LEFT DEFERED INTERNAL
SYMFIX: TLNN V,100000 ;CHECK FOR SYMBOL TABLE FIXUP
POPJ P, ;NO, RETURN
ADDI V,(X) ;GET THE LOCATION
SYMFX1: MOVE T,-1(V) ;GET THE SYMBOL NAME
TLNN T,40000 ;CHECK TO SEE IF INTERNAL
POPJ P, ;NO, LEAVE
ANDCAB D,-1(V) ;REMOVE PROPER BIT
TLNE D,600000 ;IS IT STILL DEFERED?
POPJ P, ;YES, ALL DONE
EXCH C,D ;NO, CHECK FOR A REQUEST FOR IT
PUSHJ P,SREQ
JRST CHNSYM ;YES, WILL HAVE TO CALL THE FIXUP ROUTINE
MOVE C,D ;GET C BACK
POPJ P,
CHNSYM: PUSH P,D ;HAS THE OLD C IN IT
PUSH P,W ;WE MAY NEED IT LATER
MOVE W,(V) ;GET VALUE
PUSHJ P,SYM2B ;CALL THE FOUND GLOBAL TO MATCH REQUEST ROUTINE
POP P,W
POP P,C ;RESTORE FOR CALLER
POPJ P, ;AND GO AWAY
SYM2W: IFN FAILSW,<
TLNE V,40000 ;CHECK FOR POLISH
JRST POLSAT>
TLNN V,100000 ;SYMBOL TABLE?
JRST SYM2WA
ADD V,HISTRT ;MAKE ABSOLUTE
SUBI V,(X) ;GET READY TO ADD X
PUSHJ P,FIXW1
JRST SYM2W1
SYM2WA: PUSHJ P,FIXW ;DO FIXUP
JRST SYM2W1 ;AND LOOK FOR MORE REQUESTS
;END WFW PATCH
;PATCH VALUES INTO CHAINED REQUEST
SYM4: IFN L,<CAMGE V,RINITL
POPJ P,>
IFN REENT,<CAMGE V,HVAL1
SKIPA X,LOWX
MOVE X,HIGHX>
HRRZ T,@X ;LOAD NEXT ADDRESS IN CHAIN
HRRM W,@X ;INSERT VALUE INTO PROGRAM
MOVE V,T
SYM4A: JUMPN V,SYM4 ;JUMP IF NOT LAST ADDR. IN CHAIN
POPJ P,
IFE K,<
MVDWN: HRRZ T,MLTP
IFN EXPAND,< SUBI T,2>
CAIG T,(H); ANY ROOM LEFT?
IFN EXPAND,< JRST [PUSHJ P,XPAND>
TLOA F,FULLSW
IFN EXPAND,< JRST MVDWN
POPJ P,]>
TLNE F,SKIPSW+FULLSW
POPJ P, ; ABORT BLT
HRREI T,-2
ADDM T,PLTP; ADJUST PROGRAMMER LABEL POINTER
ADDM T,BITP; AND BIT TABLE POINTER
ADDM T,SDSTP; FIRST DATA STATEMENT
ADDM T,LTC
ADDM T,ITC
TLNE N,SYDAT
ADDM T,V
ADDB T,MLTP; AND FINALLY TO MADE LABEL TABLE
HRLS T; SET UP BLT POINTER
ADD T,[XWD 2,0]
BLT T,(S)
POPJ P,
>
SUBTTL HIGH-SEGMENT (BLOCK TYPE 3)
;THIS PROGRAM IS INTENDED FOR HI SEGMENT IF RUNNING ON A PDP-10.
; THIS BLOCK TYPE OCCURS AFTER ENTRY AND NAME BLOCKS.
HISEG: PUSHJ P,WORD ;GOBBLE UP A WORD.
JUMPE W,HISEG2 ;MACRO V36
PUSHJ P,WORD ;GET THE OFSET
IFE REENT,<HISEG2==LOAD1A
JUMPGE W,LOAD1A ;NOT TWO SEG PROG.>
IFN REENT,<JUMPE W,HISEG2 ;IGNORE ZERO
JUMPG W,HISEG3 ;NEG. IF TWOSEG PSEUDO-OP>
TRO F,TWOFL ;SET FLAG
IFN REENT,<
TRNE F,NOHI!NOHI6 ;TWO SEGMENTS LEGAL?
JRST ONESEG ;LOAD AS ONE SEGMENT
HISEG3: HRRZ D,W ;GET START OF HISEG
JUMPE D,.+2 ;NOT SPECIFIED
PUSHJ P,HCONT ;AS IF /H
HISEG2: PUSHJ P,HISEG1
JRST LOAD1 ;GET NEXT BLOCK
FAKEHI: ;AS IF BLOCK TYPE 3
HISEG1: TRNE F,NOHI!NOHI6 ;LOAD REENT?
POPJ P,
TLOE F,HIPROG ;LOADING HI PROG
POPJ P, ;IGNORE 2'ND HISEG
TRON F,SEENHI ;HAVE WE LOADED ANY OTHER HI STUFF?
PUSHJ P,SETUPH ;NO,SET UP HI SEG.
MOVEM R,LOWR
MOVE R,HIGHR
HRRM R,2(N) ;CALL THIS THE START OF THE PROGRAM
MOVE X,HIGHX
POPJ P,
SETUPH: MOVE X,HVAL1
CAIGE X,-1 ;SEE IF IT HAS BEEN CHANGED FROM ORIG
JRST SEENHS ;YES, MUST HAVE SEEN /H
MOVEI X,400000
MOVEM X,HVAL1
CAIG X,(H) ;HAVE WE RUN OVER WITH THE LOW SEG
JRST COROVL
ADDI X,JOBHDA
HRLI X,W
MOVEM X,HVAL
SEENHS: MOVE X,HVAL
MOVEM X,HIGHR
HRRZ X,JOBREL
SUB X,HVAL1
ADDI X,1
HRLI X,V
MOVEM X,HIGHX
POPJ P,
SETSEG: TRZ F,NOHI!SEGFL ;ALLOW HI-SEG
JUMPL D,.+2 ;/-H TURNS OFF NOHI ONLY
TRO F,SEGFL ;/1H FORCES HI
POPJ P,
>
ONESEG: HLRZ D,W ;GET LENGTH OF HISEG
SUBI D,(W) ;REMOVE OFSET
JUMPLE D,TWOERR ;LENGTH NOT AVAILABLE
MOVEM R,LOWR ;SAVE LOW SEGMENT RELOCATION
ADDM D,LOWR ;ADD TO LOW SEG RELOCATION
HRRZM W,HVAL1 ;SO RELOC WILL WORK
JRST LOAD1 ;GET NEXT BLOCK
TWOERR: ERROR 7,</TWO SEGMENTS ILLEGAL#/>
JRST LDRSTR
SUBTTL HIGHEST RELOCATABLE POINT (BLOCK TYPE 5)
SFULLC: TLOE F,FULLSW ;PREVIOUS OVERFLOW?
JRST FULLC ;YES, DON'T PRINT MESSAGE
ERROR ,<?SYMBOL TABLE OVERLAP#?>
FULLC: TLO F,FULLSW ;CORE OVERLAP ERROR RETURN
IFE K,< TLNE N,F4SW
POPJ P,>
JRST LIB3 ;LOOK FOR MORE
HIGH2: PUSHJ P,RWORD ;GET HISEG BREAK
TRZ F,TWOFL ;CLEAR FLAG NOW
IFE REENT,< MOVE R,LOWR
JRST HIGH2A>
IFN REENT,< TRNE F,NOHI!NOHI6 ;SINGLE SEGMENT LOAD?
JRST [MOVE R,LOWR ;YES,GET LARGER RELOC
MOVE W,HVAL ;ORIGINAL VALUE
MOVEM W,HVAL1 ;RESET
JRST HIGH2A] ;CONTINUE AS IF LOW ONLY
HRR R,W ;PUT BREAK IN R
CAMLE R,HVAL
MOVEM R,HVAL
MOVEM R,HIGHR
MOVE R,LOWR ;NEXT WORD IS LOW SEG BREAK
TLZ F,HIPROG ;CLEAR HIPROG
PUSHJ P,PRWORD ;GET WORD PAIR
HRR R,C ;GET LOW SEG BREAK
MOVEM R,LOWR ;SAVE IT
MOVE R,HIGHR ;GET HIGH BREAK
JRST HIGHN3 ;AND JOIN COMMON CODE>
HIGH0: CAIE A,4 ; TEST FOR END BLOCK (OVERLAP)
JRST LIB30
HIGH: TRNE F,TWOFL ;IS THIS A TWO SEGMENT PROGRAM?
JRST HIGH2 ;YES
HIGH2A: PUSHJ P,PRWORD ;READ TWO DATA WORDS.
IFN REENT,< TLZE F,HIPROG
JRST HIGHNP>
IFN WFWSW,<ADD C,VARLNG ;IF LOW SEG THEN VARIABLES GO AT END>
IFN ALGSW,<ADD C,OWNLNG ;ADD IN LENGTH OF OWN BLOCK>
HRR R,C ;SET NEW PROGRAM BREAK
CAMGE C,W ;CHECK 2ND WORD (LOC PROG BRK IF PRESENT)
MOVE C,W
HIGH31: ADDI C,(X)
CAIG H,(C)
MOVEI H,(C) ;SET UP H
CAILE H,1(S) ;TEST PROGRAM BREAK
IFN EXPAND,<PUSHJ P,[ PUSHJ P,XPAND
TLOA F,FULLSW
JRST POPJM2
POPJ P,]>
IFE EXPAND,<TLO F,FULLSW>
HIGH3: MOVEI A,F.C
BLT A,B.C
IFN REENT,<TRNE F,NOHI!NOHI6 ;ONE SEGMENT PROGRAM?
JRST HIGHN4 ;YES
HRLZ W,HIGHR ;GET HIGH PROG BREAK
JUMPE W,[HRRZ W,R ;NO HIGH SEGMENT YET
JRST .+2] ;SO USE LOW RELOCATION ONLY
HRR W,LOWR ;GET LOW BREAK
SETZ C, ;ZERO SYMBOL NAME
PUSHJ P,SYM1B ;PUT IN SYMBOL TABLE
MOVEM S,F.C+S ;SAVE NEW S AND B
MOVEM B,F.C+B ;INCASE OF ERROR
HIGHN4:>
TLZ F,NAMSSW ;RELAX, RELOCATION BLOCK FOUND
TLNE F,SLIBSW+LIBSW ;NORMAL MODE EXIT THROUGH LOAD1
JRST LIB ;LIBRARY SEARCH EXIT
JRST LOAD1
IFN REENT,<
HIGHNP: HRR R,C
HIGHN1: CAMLE R,HVAL
MOVEM R,HVAL
MOVEM R,HIGHR
HIGHN3: PUSH P,W ;SAVE W,CONTAIN HIGHEST ABSOLUTE ADDRESS
ADD W,LOWX ;LOC PROG BRK
CAIGE H,(W) ;CHECK FOR TOP OF LOW CORE
MOVEI H,(W)
POP P,W ;RESTORE
CAML H,HVAL1
JRST COROVL ;OVERFLOW OF LOW SEGMENT
HIGHN2: HRRZ R,HVAL
SUB R,HVAL1
ADD R,HISTRT
CAMLE R,JOBREL
JRST [PUSHJ P,HIEXP
JRST FULLC
JRST HIGHN2]
MOVE R,LOWR
MOVE X,LOWX
IFN WFWSW,<ADD R,VARLNG ;VARIABLES IN LOW SEG>
IFN ALGSW,<ADD R,OWNLNG ;OWN BLOCK IN LOW SEGMENT>
HRRZ C,R
CAIGE C,(W) ;IS ABSOLUTE LOCATION GREATER
HRR R,W ;YES USE IT
HRRZ C,R ;SET UP C AGAIN
JRST HIGH31 ;GO CHECK PROGRAM BREAK
SUBTTL EXPAND HIGH SEGMENT
HIEXP: TLNE F,FULLSW
POPJ P,
IFN EXPAND,<PUSH P,Q>
PUSH P,H
PUSH P,X
PUSH P,N
IFE K,<HRRZ X,MLTP
TLNN N,F4SW>
MOVEI X,1(S)
HRRZ N,X
SUB N,H
CAILE N,1777
JRST MOVHI
IFE EXPAND,<POPJ P,>
IFN EXPAND,<HRRZ N,JOBREL
ADDI N,2000
CAMG N,ALWCOR
CORE N,
JRST XPAND6
PUSHJ P,ZTOP
POP P,N
JRST XPAND3>
MOVHI: MOVEI N,-2000(X)
HRL N,X
HRRZ X,JOBREL
BLT N,-2000(X)
PUSHJ P,ZTOP
MOVNI H,2000
IFN EXPAND,<JRST XPAND8>
IFE EXPAND,<ADDM H,HISTRT
ADDM H,S
ADDM H,B
ADDM H,HIGHX
TLNE F,HIPROG
ADDM H,-1(P)
POP P,N
SUBI N,2000 ;ADJUST POINTER TO NAME
IFE K,< TLNN F4SW
JRST HIXP1
ADDM H,PLTP
ADDM H,BITP
ADDM H,SDSTP
ADDM H,MLTP
TLNE N,SYDAT
ADDM H,V
HIXP1:>
POP P,X
POP P,H
AOS (P)
POPJ P,>
ZTOP: HRRZ N,JOBREL
MOVEI X,-1776(N)
HRLI X,-1777(N)
SETZM -1(X)
BLT X,(N)
POPJ P,>
SUBTTL PROGRAM NAME (BLOCK TYPE 6)
NAME: TLOE F,NAMSSW ;HAVE WE SEEN TWO IN A ROW?
JRST NAMERR ;YES, NO END BLOCK SEEN
PUSHJ P,PRWORD ;READ TWO DATA WORDS
MOVEM C,SBRNAM ;SAVE SUBROUTINE NAME
NCONT: HLRE V,W ;GET COMPILER TYPE
HRRZS W ;CLEAR TYPE
JUMPL V,.+3
CAIGE V,CMPLEN-CMPLER ;ONLY IF LEGAL TYPE
XCT CMPLER(V) ;DO SPECIAL FUNCTION
TLOE N,COMFLG ;SKIP IF COMMON NOT PREV. SET
JRST NAME1 ;SIZE OF COMMON PREV. SET
MOVEM W,COMSAV ;STORE LENGTH OF COMMON
JUMPE W,NAME2 ;JUMP IF NO COMMON IN THIS JOB
HRRI R,@R ;FIRST PROGRAM SET LOAD ORIGIN
NAME1: CAILE H,-1(S) ;TEST FOR AVAIL. SYMBOL SPACE
IFN EXPAND,< PUSHJ P,XPAND7>
IFE EXPAND,< JRST SFULLC>
SUBI S,2 ;UPDATE UNDEF. TABLE POINTER
POP B,2(S)
POP B,1(S)
HRRZ V,N ;POINTER TO PREVIOUS NAME
SUBM B,V ;COMPUTE RELATIVE POSITIONS
HRLM V,2(N) ;STORE FORWARD POINTER
HRR N,B ;UPDATE NAME POINTER
NAME2: MOVEM C,1(B) ;STORE PROGRAM NAME
HRRZM R,2(B) ;STORE PROGRAM ORIGIN
CAMG W,COMSAV ;CHECK COMMON SIZE
IFE REENT,<JRST LIB3 ;COMMON OK>
IFN REENT,<JRST [TRNE F,SEGFL ;LOAD LOW IN HI-SEG
PUSHJ P,FAKEHI ;YES
JRST LIB3]>
SKIPA C,COMM
ILC: MOVE C,1(A) ;NAME
PUSH P,C ;SAVE COMMON NAME
ERROR ,</ILL. COMMON !/>
POP P,C
PUSHJ P,PRNAME
ILC1: SKIPN SBRNAM
JRST ILC2
ERROR 0,</ PROG. !/>
MOVE C,SBRNAM ;RECOVER SUBROUTINE NAME
PUSHJ P,PRNAME
ILC2: ERROR 0,</ #/>
JRST LD2
NAMERR: SETZM DTIN ;CLEAR WRONG FILE NAME FOR MESSAGE
ERROR ,</NO END BLOCK !/>
JRST ILC1
;COMPILER TYPE - DO SPECIAL FUNCTION FOR IT
DEFINE CTYPE (CONDITION,TRUE,FALSE)
<IFN CONDITION,<TRUE>
IFE CONDITION,<FALSE>>
CMPLER: CTYPE 1,JFCL,JFCL ;0 MACRO
CTYPE K-1,<TRO F,F4FL>,JFCL ;1 FORTRAN
CTYPE 1,<TRO F,COBFL>,JFCL ;2 COBOL
CTYPE ALGSW,<PUSHJ P,ALGNAM>,JFCL ;3 ALGOL
;4 NELIAC
;5 PL/1
CMPLEN:
SUBTTL STARTING ADDRESS (BLOCK TYPE 7)
START: PUSHJ P,PRWORD ;READ TWO DATA WORDS
TLNN N,ISAFLG ;SKIP IF IGNORE SA FLAG ON
HRRZM C,STADDR ;SET STARTING ADDRESS
IFN STANSW&REENT,<
MOVE W,DTIN+2
TLNN N,ISAFLG
MOVEM W,PRGCRD ;SAVE DATE & TIME FOR SETCRD>
IFN NAMESW,<
MOVE W,DTIN ;PICK UP BINARY FILE NAME
TLNN N,ISAFLG
MOVEM W,PRGNAM ;SAVE IT
MOVE W,1(N) ;SET UP NAME OF THIS PROGRAM
TLNN N,ISAFLG ;DONT SET NAME IF IGNORING SA'S
PUSHJ P,LDNAM>
PUSHJ P,PRWORD ;**OBSCURE RETURN TO LOAD1**
IFN REENT,<
RESTRX: TLNE F,HIPROG
SKIPA X,HIGHX
MOVE X,LOWX
POPJ P,>
SUBTTL ONE PASS LOCAL DEFINITION (BLOCK TYPE 10)
;PMP PATCH FOR LEFT HALF FIXUPS
IFN FAILSW!WFWSW,<
LOCDLH: IFN L,<CAMGE V,RINITL
POPJ P,>
IFN REENT,<CAMGE V,HVAL1
SKIPA X,LOWX
MOVE X,HIGHX>
HLRZ T,@X ;LOAD NEXT ADDRESS IN CHAIN
HRLM W,@X ;INSERT VALUE INTO PROGRAM
MOVE V,T
LOCDLF: JUMPN V,LOCDLH ;JUMP IF NOT LAST ADDR. IN CHAIN
POPJ P,>
IFN FAILSW,<
LOCDLI: PUSHJ P,LOCDLF
IFN REENT,<PUSHJ P,RESTRX>
AOSA LFTHSW ;TURN OFF LEFT HALF FIX SW (WAS -1) AND SKIP
LOCDLG: SETOM LFTHSW ;TURN ON LEFT HALF FIX SW>
;END PMP PATCH
LOCD: PUSHJ P,RWORD ;READ ONE DATA WORD
HLRZ V,W ;STORAGE POINTER IN LEFT HALF
IFN FAILSW,<
SKIPE LFTHSW ;LEFT HALF CHAINED? PMP
JRST LOCDLI ;YES PMP
CAMN W,[-1] ;LEFT HALF NEXT? PMP
JRST LOCDLG ;YES, SET SWITCH PMP>
PUSHJ P,SYM4A ;LINK BACK REFERENCES
IFN REENT,<PUSHJ P,RESTRX>
JRST LOCD
SUBTTL LVAR FIX-UP (BLOCK TYPE 13)
IFN WFWSW,<
LVARB: PUSHJ P,PRWORD ;THE FIRST TWO WORDS IN THE BLOCK
MOVEM W,VARLNG ;AR SPECIAL. SECOND IS LENGTH OF VARIABLES
IFN REENT,< TLNE F,HIPROG
MOVE C,LOWR ;USE LOW RELOC IF LOADING HI SEG>
;ELSE C HAS RELOC FOR THIS PROGRAM, USE IT
HRRZM C,VARREL ;THIS IS LOCATION 0 OF VARIABLE AREA
LVLP: PUSHJ P,PRWORD ;THINGS COME IN PAIRS
TLNE C,200000 ;BIT ON IF SYMBOL TABLE FIXUP
JRST LVSYM
HLRZ V,W ;NO GET LOC FROM LEFTH HALF OF SECOND
ADD W,VARREL ;AND RELOCATE VARIABLE
TLNE C,400000 ;ON FOR LEFT HALF
JRST [PUSHJ P,LOCDLF ;TAKE CARE OF IT
IFN REENT,< JRST LVLCOM] ;RESET X>
IFE REENT,< JRST LVLP] ;MUST BE LOW SEG X OK>
PUSHJ P,SYM4A ;RIGHT HALF CHAIN
IFN REENT,<LVLCOM: PUSHJ P,RESTRX>
JRST LVLP
LVSYM: MOVE V,B ;GET SYMBOL TABLE POINTER
ADD C,VARREL ;VALUE IS IN FIRST WORD FOR THESE
TLZ W,740000 ;MAKE SURE NO BITS ON
ADDI V,2 ;CORRECT POINTER TO SYMBOL TABLE
SRSYM: MOVE A,-1(V) ;GET A NAME
TLZN A,740000 ;CHECK FOR PROGRAM NAME
JRST LVLP ;LEAVE (PROBABLY A NON-LOADED LOCAL)
CAMN A,W ;IS IT THE RIGHT ONE??
JRST LVSYMD ;YES
ADD V,SE3 ;CHECK NEXT ONE
JUMPL V,SRSYM ;BUT ONLY IF SOME ARE THERE
JRST LVLP ;GIVE UP
LVSYMD: TLNE C,400000 ;WHICH HALF??
JRST LVSYML ;LEFT
ADD C,(V) ;ADDITIVE FIXUP
HRRM C,(V)
MOVSI D,200000 ;DEFERED BITS
LVSM1: PUSHJ P,COMSFX ;GO TAKE CARE OF IT
JRST LVLP ;NEXT PLEASE
LVSYML: HRLZS C
ADDM C,(V) ;WE DON'T HAVE TO WORRY ABOUT OVERFLOW HERE
MOVSI D,400000 ;LEFT DEFERED BITS
JRST LVSM1 ;GO WORRY ABOUT DEFERED INTERNALS>
SUBTTL FAIL LOADER
;ONLY LIST IF FAILSW=1
XLIST
IFN FAILSW,<LIST>
REPEAT 0,<IF POLISH FIXUPS CONTAIN GLOBAL REQUESTS WHICH
CAN NOT BE SATISFIED WHEN THEY ARE SEEN, THEY MUST BE
SAVED UNTIL THESE GLOBAL SYMBOLS BECOME DEFINED.
THE POLISH FIXUP IS SAVED IN THE UNDEFINED TABLE (POINTED
TO BY S). THE FIXUP IS SAVED IN TWO WORD BLOCKS THE FIRST
WORD OF WHICH (THE ONE WHICH WOULD NORMALL CONTAIN THE SYMBOL)
HAS SPECIAL BITS ON SO IT WILL NOT BE FOUND BY A SEARCH FOR
A GLOBAL REQUEST. SINCE THE UNDEFINED TABLE MAY BE
SHUFFELED INTO A RANDOM ORDER, IT IS NOT POSSIBLE TO KEEP
ALL OF A POLISH FIXUP TOGETHER OR TO HAVE POINTERS IN
THE USUAL SENCE FROM ONE TWO WORD BLOCK TO ANOTHER.
SUFFICIENT INFORMATION IS THEREFORE GIVEN TO DETERMINE
WHAT THE FIRST WORD OF THE NEXT DESIRED BLOCK IS AND THIS
BLOCK IS FOUND BY SEARCHING THE UNDEFINED TABLE FOR A MATCH.
EACH POLISH FIXUP WHICH IS ENTERED INTO THE UNDEFINED
TABLE IS GIVEN A UNIQUE NUMBER CALLED THE "HEAD NUMBER".
EACH ELEMENT OF THE FIXUP (EITHER OPERAND OR OPERATOR)
IS ASSIGNED A NUMBER CALLED THE "OP NUMBER". THUS
THE OP NUMBER AND HEAD NUMBER TOGETHER DETERMINE
A SPECIFIC ELEMENT OF A SPECIFIC FIXUP. EACH ELEMENT
(TWO WORD BLOCK) IS ARRANGED AS FOLLOWS:
WORD 1:
BITS 0-4 THESE ARE THE USUAL CODE BITS OF A RADIX50
SYMBOL AND CONTAIN 44 TO DISTINGUISH
AN ELEMENT OF A POLISH FIXUP FROM OTHER
SYMBOLS IN THE UNDEFINED TABLE
BITS 5-17 THE HEAD NUMBER OF THIS FIXUP
BITS 18-30 THE OP NUMBER OF THIS ELEMENT
BITS 31-35 THE OPERAND FOR THIS ELEMENT
OPERAND 2 INDICATES A WORD OF DATA
WORD 2:
IF THE OPERAND IS 2 THIS WORD CONTAINS THE DATA
IF THIS IS NOT A DATA OPERATOR THEN THE LEFT AND
RIGHT HALVES OF THIS WORD POINT TO THE TWO OPERANDS
THE CONTENTS OF THE HALF WORD IS THE RIGHT HALF
OF THE FIRST WORD OF THE BLOCK POINTED
TO. THUS THE LEFT HALF OF THE FIRST WORD COMBINED
WITH ONE OF THESE HALF WORDS IS THE FIRST WORD
OF THE BLOCK POINTED TO AND CAN BE FOUND BY SEARCHING
EACH FIXUP ALSO HAS A HEADER BLOCK. THIS BLOCK CONTAINS THE
FOLLOWING INFORMATION:
WORD 1:
BITS 0-17 0
BITS 18-21 44
BITS 22-35 THE HEAD NUMBER OF THIS FIXUP
WORD 2:
BITS 0-17 A COUNT OF THE NUMBER OF UNDEFINED
GLOBALS REMAINING IN THIS FIXUP
BITS 18-35 A HALF WORD POINTER OF THE
SAME TYPE FOUND IN OTHER ELEMENTS POINTING
TO THE FIRST ELEMENT OF POLISH
WHICH WILL BE THE STORE OPERATOR
THE REQUESTS FOR THE GLOBAL SYMBOLS NEEDED BY THE FIXUP ARE
ENTERED AS FOLLOWS:
WORD 1:
BITS 0-4 04
BITS 5-35 RADIX 50 FOR THE NAME OF THE SYMBOL
(NOTE THIS IS JUST A STANDARD GLOBAL REQUEST)
WORD 2:
BITS 0-4 44 (THIS IDENTIFIES IT AS "ADITIVE TYPE"
AND BIT 4 INDICATES POLISH)
BITS 5-17 THE HEAD NUMBER OF THE FIXUP
(THIS GIVES ENOUGH INFORMATION TO FIND THE HEADER
BLOCK AND UPDATE THE COUNT WHEN THE REQUEST IS
SATISFIED)
BITS 18-35 A HALF WORD POINTER TO THE ELEMENT OF THE
FIXUP INTO WHICH THE VALUE OF
THE SYMBOL SHOULD BE STORED
>
IFN FAILSW,<
;POLISH FIXUPS <BLOCK TYPE 11>
PDLOV: SKIPE POLSW ;PDL OV ARE WE DOING POLISH?
JRST COMPOL ;YES
ERROR ,</PUSHDOWN OVERFLOW#/>
JRST LD2
COMPOL: ERROR ,</POLISH TOO COMPLEX#/>
JRST LD2
;READ A HALF WORD AT A TIME
RDHLF: TLON N,HSW ;WHICH HALF
JRST NORD
PUSHJ P,RWORD ;GET A NEW ONE
TLZ N,HSW ;SET TO READ OTEHR HALF
MOVEM W,SVHWD ;SAVE IT
HLRZS W ;GET LEFT HALF
POPJ P, ;AND RETURN
NORD: HRRZ W,SVHWD ;GET RIGHT HALF
POPJ P, ;AND RETURN
POLFIX: MOVE D,[IOWD PPDL,PPDB] ;SET UP THE POLISH PUSHDOWN LIST
MOVEI V,100 ;IN CASE OF ON OPERATORS
MOVEM V,SVSAT
SETOM POLSW ;WE ARE DOING POLISH
TLO N,HSW ;FIX TO READ A WORD THE FIRST TIME
SETOM GLBCNT ;NUMBER OF GLOBALS IN THIS FIXUP
SETOM OPNUM ;NUMBER OF OPERANDS AND OPERATORS THIS FIXUP
PUSH D,[15] ;FAKE OPERATOR SO STORE WILL NOT HACK
RPOL: PUSHJ P,RDHLF ;GET A HLAF WORD
TRNE W,400000 ;IS IT A STORE OP?
JRST STOROP ;YES, DO IT
IFN WFWSW,<CAIN W,15
JRST [PUSHJ P,RDHLF ;THIS TRICK FOR VARIABLES
ADD W,VARREL ;HOPE SOMEONE HAS DONE
HRRZ C,W ;A BLOCK TYPE 13
JRST HLFOP]>
CAIGE W,3 ;0,1,2 ARE OPERANDS
JRST OPND
CAILE W,14 ;14 IS HIGHEST OPERATOR
JRST LOAD4A ;ILL FORMAT
PUSH D,W ;SAVE OPERATOR IN STACK
MOVE V,DESTB-3(W) ;GET NUMBER OF OPERANDS NEEDED
MOVEM V,SVSAT ;ALSO SAVE IT
JRST RPOL ;BACK FOR MORE
;HANDLE OPERANDS. THIS GETS COMPLICATED BECAUSE OF THE PRESENCE OF
;GLOBAL REQUESTS
OPND: MOVE A,W ;GET THE OPERAND TYPE HERE
PUSHJ P,RDHLF ;THIS IS AT LEAST PART OF THE OPERAND
MOVE C,W ;GET IT INTO C
JUMPE A,HLFOP ;0 IS HALF-WORD OPERAND
PUSHJ P,RDHLF ;NEED FULL WORD, GET SECOND HALF
HRL C,W ;GET HALF IN RIGHT PLACE
MOVSS C ;WELL ALMOST RIGHT
SOJE A,HLFOP ;1 IS FULL WORD, 2 IS GLOBAL REQUEST
PUSHJ P,SDEF ;SEE IF IT IS ALREADY DEFINED
JRST [MOVE C,2(A) ;YES, WE WIN
JRST HLFOP]
AOSN GLBCNT ;NO, INCREMENT NUMBER OF GLOBALS THIS FIXUP
AOS HEADNM ;INCREMENT FIXUP NUMBER IF FIRST GLOBAL
AOS W,OPNUM ;GET AN OPERAND NUMBER
LSH W,5 ;SPACE FOR TYPE
IORI W,2 ;TYPE 2 IS GLOBAL
HRL W,HEADNM ;GET FIXUP NUMBER
PUSHJ P,SYM3X2 ;AND PUT INTO UDEFINED AREA ALONG WITH NAME
MOVE C,W ;ALSO PUT THAT PART OF THE FIXUP IN
PUSHJ P,SYM3X2
SKIPA A,[400000] ;SET UP GLOBAL FLAG
HLFOP: MOVEI A,0 ;VALUE OPERAND FLAG
HLFOP1: SOJL V,CSAT ;ENOUGH OPERANDS SEEN?
PUSH D,C ;NO, SAVE VALUE(OR GLOBAL NAME)
HRLI A,400000 ;PUT IN A VALUE MARKER
PUSH D,A ;TO THE STACK
JRST RPOL ;GET MORE POLISH
;HAVE ENOUGH OPERANDS FOR THE CURRENT OPERATOR
CSAT: HRRZS A ;KEEP ONLY THE GLOBAL-VALUE HALF
SKIPN SVSAT ;IS IT UNARY
JRST UNOP ;YES, NO NEED TO GET 2ND OPERAND
HRL A,(D) ;GET GLOBAL VALUE MARKER FOR 2ND OP
POP D,W
POP D,W ;VALUE OR GLOBAL NAME
UNOP: POP D,V ;OPERATOR
JUMPN A,GLOB ;IF EITHER IS A GLOBAL HANDLE SPECIALLY
XCT OPTAB-3(V) ;IF BOTH VALUES JUST XCT
MOVE C,W ;GET THE CURRENT VALUE
SETSAT: SKIPG V,(D) ;IS THERE A VALUE IN THE STACK
MOVE V,-2(D) ;YES, THIS MUST BE THE OPERATOR
MOVE V,DESTB-3(V) ;GET NUMBER OF OPERANDS NEEDED
MOVEM V,SVSAT ;SAVE IT HERE
SKIPG (D) ;WAS THERE AN OPERAND
SUBI V,1 ;HAVE 1 OPERAND ALREADY
JRST HLFOP1 ;GO SEE WHAT WE SHOULD DO NOW
;HANDLE GLOBALS
GLOB: TRNE A,-1 ;IS IT IN RIGHT HALF
JRST TLHG ;NO, NEED TO PUT THIS VALUE INTO THE FIXUP LIST
PUSH P,W ;SAVE FOR A WHILE
MOVE W,C ;THE VALUE
AOS C,OPNUM ;GET AN OPERAND NUMBER
LSH C,5 ;AND PUT IN TYPE
IORI C,2 ;VALUE TYPE
HRL C,HEADNM ;THE FIXUP NUMBER
PUSHJ P,SYM3X2
POP P,W ;RETRIEVE THE OTHER VALUE
TLHG: SKIPE SVSAT ;WAS THIS A UNARY OPERATOR
TLNE A,-1 ;WAS THERE A GLOBAL IN LEFT HALF
JRST GLSET
PUSH P,C ;SAVE THE FIRST OPERAND
AOS C,OPNUM ;SEE ABOVE
LSH C,5
IORI C,2
HRL C,HEADNM
PUSHJ P,SYM3X2
MOVE W,C
POP P,C
GLSET: EXCH C,W ;GET THEM IN THE OTHER ORDER
HRL W,C ;SET UP THE OPERATOR LINK
AOS C,OPNUM
LSH C,5 ;SPACE FOR THYPE
IOR C,V ;THE OPERATOR
HRL C,HEADNM
PUSHJ P,SYM3X2 ;INTO THE UNDEF LIST
MOVEI A,400000 ;SET UP AS A GLOBAL VALUE
JRST SETSAT ;AND SET UP FOR NEXT OPERATOR
;FINALLY WE GET TO STORE THIS MESS
STOROP: MOVE T,-2(D) ;THIS SHOULD BE THE FAKE OPERATOR
CAIE T,15 ;IS IT
JRST LOAD4A ;NO, ILL FORMAT
HRRZ T,(D) ;GET THE VALUE TYPE
JUMPN T,GLSTR ;AND TREAT GLOBALS SPECIAL
MOVE A,W ;THE TYPE OF STORE OPERATOR
CAIGE A,-3
PUSHJ P,FSYMT
PUSHJ P,RDHLF ;GET THE ADDRESS
MOVE V,W ;SET UP FOR FIXUPS
POP D,W ;GET THE VALUE
POP D,W ;AFTER IGNORING THE FLAG
PUSHJ P,@STRTAB+6(A) ;CALL THE CORRECT FIXUP ROUTINE
COMSTR: SETZM POLSW ;ALL DONE WITH POLISH
IFN REENT,<PUSHJ P,RESTRX>
MOVE T,OPNUM ;CHECK ON SIZES
MOVE V,HEADNM
CAIG V,477777
CAILE T,17777
JRST COMPOL ;TOO BIG, GIVE ERROR
PUSHJ P,RWORD ;THIS SHOULD GET US OUT (I.E RUN OUT COUNT)
JRST LOAD4A ;IF NOT, SOMETHING IS WRONG
STRTAB: EXP ALSYM,LFSYM,RHSYM,ALSTR,LOCDLF,SYM4A,FAKESY
GLSTR: MOVE A,W
CAIGE A,-3
PUSHJ P,FSYMT
PUSHJ P,RDHLF ;GET THE STORE LOCATION
MOVEI A,23(A)
POP D,V ;GET VALUE
POP D,V
HRLM V,W ;SET UP STORAGE ELEMENT
AOS C,OPNUM
LSH C,5
IOR C,A
HRL C,HEADNM
PUSHJ P,SYM3X2
MOVE W,C ;NOW SET UP THE HEADER
AOS V,GLBCNT ;WHICH HAS NUMBER OF GLOBALS
HRLM V,W
HRRZ C,HEADNM
PUSHJ P,SYM3X2
JRST COMSTR ;AND FINISH
ALSTR1: IFN L,<CAMGE V,RINITL
POPJ P,>
IFN REENT,<CAMGE V,HVAL1
SKIPA X,LOWX
MOVE X,HIGHX>
HRRZ T,@X
MOVEM W,@X ;FULL WORD FIXUPS
MOVE V,T
ALSTR: JUMPN V,ALSTR1
POPJ P,
DESTB: EXP 1,1,1,1,1,1,1,1,0,0,100
OPTAB: ADD W,C
SUB W,C
IMUL W,C
IDIV W,C
AND W,C
IOR W,C
LSH W,(C)
XOR W,C
SETCM W,C
MOVN W,C
REPEAT 7,<JRST STRSAT>
FSYMT: PUSHJ P,RDHLF ;FIRST HALF OF SYMBOL
HRL V,W
PUSHJ P,RDHLF
HRR V,W
PUSH D,A ;SAVE STORE TYPE
PUSHJ P,RDHLF ;GET BLOCK NAME
HRL C,W
PUSHJ P,RDHLF
HRR C,W
TLO C,140000 ;MAKE BLOCK NAME
PUSHJ P,SDEF ;FIND IT
CAMN A,B
JRST FNOLOC ;MUST NOT BE LOADING LOCALS
FSLP: LDB C,[POINT 32,-1(A),35] ;GET NAME
CAMN C,V
JRST FNDSYM
SUB A,SE3
CAME A,B ;ALL DONE?
JRST FSLP ;NO
FNOLOC: POP D,A
MOVEI A,0 ;SET FOR A FAKE FIXUP
AOS (P)
POPJ P,
FNDSYM: MOVEI W,(A) ;LOC OF SYMBOL
SUB W,HISTRT
POP D,A
AOS (P)
POPJ P,
LFSYM: ADD V,HISTRT
HRLM W,(V)
MOVSI D,400000 ;LEFT HALF
JRST COMSFX
RHSYM: ADD V,HISTRT
HRRM W,(V)
MOVSI D,200000
JRST COMSFX
FAKESY: POPJ P, ;IGNORE
POLSAT: PUSH P,C ;SAVE SYMBOL
MOVE C,V ;POINTER
PUSHJ P,SREQ ;GO FIND IT
SKIPA
JRST LOAD4A ;SOMETHING IS ROTTEN IN DENMARK
MOVEM W,2(A) ;STORE VALUE
HLRZS C ;NOW FIND HEADER
PUSHJ P,SREQ
SKIPA
JRST LOAD4A
HRLZI V,-1 ;AND DECREMENT COUNT
ADDB V,2(A)
TLNN V,-1 ;IS IT NOW 0
JRST PALSAT ;YES, GO DO POLISH
POP P,C ;RESTORE SYMBOL
JRST SYM2W1 ;AND RETURN
PALSAT: PUSH P,W ;SAVE VALUE
MOVEM C,HDSAV ;SAVE THE HEADER NUMBER
MOVE D,[IOWD PPDL,PPDB] ;SET UP A PDL
MOVE C,V ;GET THE POINTER
HRL C,HDSAV ;AND THE FIXUP NUMBER
PUSHJ P,REMSYM ;REMOVE THE HEADER FORM EXISTANCE
PUSHJ P,SREQ ;GO FINE THE NEXT LINK
SKIPA
JRST LOAD4A ;LOSE
ANDI C,37 ;GET OPERATOR TYPE
HRRZ V,2(A) ;PLACE TO STORE
PUSH D,V
PUSH D,[XWD 400000,0]
PUSH D,C ;THIS HAD BETTER BE A STORE OR WE ARE IN TROUBLE
HLRZ C,2(A) ;GET POINTER TO POLISH CHAIN
PSAT1: PUSHJ P,REMSYM ;REMOVE SYMBOL
PSAT2: HRL C,HDSAV ;GET FIXUP NUMBER
PUSHJ P,SREQ ;LOOK FOR IT
SKIPA
JRST LOAD4A
ANDI C,37 ;THE OPERATOR NUMBER
CAIN C,2 ;IS IT AN OPERAND?
JRST PSOPD ;YES, GO PROCESS
PUSH D,C ;YES STORE IT
SKIPN DESTB-3(C) ;IS IT UNARY
JRST PSUNOP ;YES
HLRZ C,2(A) ;GET FIRST OPERAND
HRLI C,600000 ;AND MARK AS VALUE
PUSH D,C
PSUNOP: HRRZ C,2(A) ;OTHER OPERAND
JRST PSAT1 ;AND AWAY WE GO
PSOPD: MOVE C,2(A) ;THIS IS A VALUE
PUSHJ P,REMSYM ;GET RID OF THAT PART OF THE CHAIN
PSOPD1: SKIPG V,(D) ;IS THERE A VALUE IN THE STACK
JRST PSOPD2 ;YES, TAKE GOOD CARE OF IT
COMOP: POP D,V ;NO, GET THAT OPERATOR OUT OF THERE
XCT OPTAB-3(V) ;AND DO IT
MOVE C,W ;GET RESULT IN RIGHT PLACE
JRST PSOPD1 ;AND TRY FOR MORE
PSOPD2: TLNE V,200000 ;IS IT A POINTER
JRST DBLOP ;YES, NEEDS MORE WORK
MOVE W,C ;NO, ONE WE HAVE IS FIRST OPND, GET IT INTO W
POP D,C ;VALUE POINTER
POP D,C ;2ND OPERAND INTO C
JRST COMOP ;GO PROCESS OPERATOR
DBLOP: EXCH C,(D) ;PUT VALUE IN STACK AND RETRIEV POINTER
PUSH D,[XWD 400000,0] ;MARK AS VALUE
JRST PSAT2 ;AND GO LOOK FOR MORE TROUBLE
LINK: PUSHJ P,PRWORD ;GET TWO WORDS
JUMPLE C,ENDLNK ;THIS IS AN END OF LINK WORD
CAILE C,20 ;IS IT IN RANGE?
JRST LOAD4A
HRRZ V,W ;GET THE ADDRESS
IFN REENT,<
CAMGE V,HVAL1 ;CHECK HISEG ADDRESS
SKIPA X,LOWX ;LOW SEGMENT
MOVE X,HIGHX ;HIGH SEGMENT BASE
>;IF REENT
HRRZ W,LINKTB(C) ;GET CURRENT LINK
IFN L,< CAML V,RINITL ;LOSE>
HRRM W,@X ;PUT INTO CORE
HRRM V,LINKTB(C) ;SAVE LINK FOR NEXT ONE
IFN REENT,<
PUSHJ P,RESTRX ;RESTORE X
>;IF REENT
JRST LINK ;GO BACK FOR MORE
ENDLNK: MOVNS C ;GET ENTRY NUMBER
JUMPE C,LOAD4A ;0 IS A LOSER
CAILE C,20 ;CHECK RANGE
JRST LOAD4A
HRLM W,LINKTB(C) ;SAVE END OF LINK INFO
JRST LINK ;MORE
STRSAT: MOVE W,C ;GET VALUE TO STORE IN W
MOVE C,V ;GET OPERATOR HERE
POP D,V
POP D,V ;GET ADDRESS TO STORE
PUSHJ P,@STRTAB-15(C)
IFN REENT,<PUSHJ P,RESTRX>
POP P,W ;RESTORE THINGS
POP P,C
JRST SYM2W1
ALSYM: ADD V,HISTRT
MOVEM W,(V)
MOVSI D,600000
>
LIST ;END OF FAILSW CODE
IFN FAILSW!WFWSW,<
COMSFX: IFN REENT,<PUSHJ P,SYMFX1 ;WAS IFE, I THINK THAT'S WRONG -- DCS
JRST RESTRX>
IFE REENT,<JRST SYMFX1>> ;WAS IFN, I THINK THAT'S WRONG -- DCS
REMSYM: MOVE T,1(S)
MOVEM T,1(A)
MOVE T,2(S)
MOVEM T,2(A)
ADD S,SE3
MOVEM A,SVA
POPJ P,
SUBTTL LIBRARY INDEX (BLOCK TYPE 14)
COMMENT * DIRECT ACCESS LIBRARY SEARCH MODE
INDEX WRITTEN BY FUDGE2.SEE DIDAL DOC (100-540-001-00)
DESIGN AND CODING BY D.M.NIXON JUL-AUG 1970
*
IFN DIDAL,<
INDEX8: POP P,LSTBLK ;SET UP LSTBLK FOR NEXT PROG
PUSHJ P,WORD ;READ FIRST WORD
HLRZ A,W ;BLOCK TYPE ONLY
CAIE A,14 ;IS IT AN INDEX?
JRST INDEXE ;NO, ERROR
JRST INDEX9 ;DON'T SET FLAG AGAIN
INDEX0: TRO F,XFLG ;SIGNAL INDEX IN CORE
MOVEI A,1 ;START ON BLOCK 1 (DSK)
HRROM A,LSTBLK ;BUT INDICATE AN INDEX
MOVE A,ILD1 ;INPUT DEVICE
DEVCHR A,
TLNE A,100 ;IS IT A DTA?
TRO F,DTAFLG ;YES
INDEX9: MOVEI A,AUX+2 ;AUX BUFFER
HRLI A,4400 ;MAKE BYTE POINTER
MOVEM A,ABUF1 ;AND SAVE IT
HRL A,BUFR1 ;INPUT BUFFER
BLT A,AUX+201 ;STORE BLOCK
TRO F,LSTLOD ;AND FAKE LAST PROG READ
INDEX1: ILDB T,ABUF1
HLRE A,T ;GET WORD COUNT
JUMPL A,INDEX3 ;END OF BLOCK IF NEGATIVE
CAIE A,4 ;IS IT ENTRY
JRST INDEX
HRRZS T ;WORD COUNT ONLY
INDEX2: ILDB C,ABUF1 ;GET NEXT SYMBOL
TLO C,040000 ;
PUSHJ P,SREQ ;SEARCH FOR IT
SOJA T,INDEX4 ;REQUEST MATCHES
SOJG T,INDEX2 ;KEEP TRYING
ILDB T,ABUF1 ;GET POINTER WORD
TRZN F,LSTLOD ;WAS LAST PROG LOADED?
JRST INDEX1 ;NO
TRNN F,DTAFLG ;ALWAYS SAVE IF DTA???
SKIPL LSTBLK ;SKIP IF LAST BLOCK WAS AN INDEX
MOVEM T,LSTBLK ;SAVE POINTER FOR CALCULATIONS
JRST INDEX1 ;GET NEXT PROG
INDEX4: ADDM T,ABUF1
ILDB A,ABUF1
PUSH P,A ;SAVE THIS BLOCK
TROE F,LSTLOD ;DID WE LOAD LAST PROG?
JRST [SKIPGE LSTBLK ;WAS LAST BLOCK AN INDEX?
JRST NXTBLK ;YES, SO GET NEXT ONE
MOVEM A,LSTBLK
JRST LOAD1] ;NEXT PROG IS ADJACENT
HRRZ T,LSTBLK ;GET LAST BLOCK NUMBER
CAIN T,(A) ;IN THIS BLOCK?
JRST THSBLK ;YES
NXTNDX: TRNE F,DTAFLG ;DIFFERENT TEST FOR DTA
JRST NXTDTA ;CHECK IF NEXT BUFFER IN CORE
CAIN T,-1(A) ;NEXT BLOCK?
JRST NXTBLK ;YES,JUST DO INPUT
INDEX5: USETI 1,(A) ;SET ON BLOCK
WAIT 1, ;LET I/O FINISH
MOVSI C,(1B0) ;CLEAR RING USE BIT IF ON
; ***** THE EQUIV. OF THE NEXT INSTR. MAY WELL BE IN LATER VERSIONS.
; ***** IT WAS MISSING, AND FOULED UP THE INDEX STUFF. (DCS 7-7-71)
HLLM C,BUFR ;INDICATE VIRGIN BUFFER
HRRZ T,BUFR
SKIPL (T)
JRST NXTBLK ;ALL DONE NOW
ANDCAM C,(T) ;CLEAR USE BIT
HRRZ T,(T) ;GET NEXT BUFFER
JRST .-4 ;LOOP
NXTDTA: WAIT 1, ;LET I/O RUN TO COMPLETION
HRRZ T,BUFR ;GET POINTER TO CURRENT BUFFER
HLRZ T,1(T) ;FIRST DATA WORD IS LINK
CAIE T,(A) ;IS IT BLOCK WE WANT?
JRST INDEX5 ;NO
NXTBLK: IN 1,
JRST NEWBLK ;IT IS NOW
JRST WORD3 ;EOF OR ERROR
NEWBLK: MOVE A,(P) ;GET CURRENT BLOCK
JUMPL A,INDEX8 ;JUST READ AN INDEX
HLRZS A ;GET WORD COUNT
COMMENT * DCS -- 3/15/71
This code required modification to work with DEC's FUDGE2
(with /X) at Stanford. I don't know the formats, so I don't know
if the bugs are unique to Stanford.
In particular, the special 0 test seems to cause all the
trouble -- removing it fixed it. However, my fix may well foul
up with Dectapes (see the SPR for "details?").
*
; 0 TEST REMOVED HERE -- DCS
SKIPL LSTBLK ;WAS LAST BLOCK AN INDEX?
AOJA A,INDEX6 ;NO, ALWAYS ONE WORD OUT THEN
HRRZ T,AUX+3 ;GET FIRST ENTRY BLOCK TYPE COUNT
HRRZ T,AUX+4(T) ;GET FIRST POINTER WORD
MOVEM T,LSTBLK ;SOME WHERE TO STORE IT
HRRZ T,(P) ;GET CURRENT BLOCK NUMBER
CAME T,LSTBLK ;SAME BLOCK
AOJA A,INDEX6 ;NO
TRNN F,DTAFLG ;BUFR2 OK IF DTA
SOS BUFR2 ;ONE WORD TOO MANY THOUGH
JRST INDEX6 ;YES, WORD COUNT WILL BE CORRECT
; IF A IS 0, INDEX6≡INDEX7 -- DCS
THSBLK: SUB A,LSTBLK ;GET WORD DIFFERENCE
MOVSS A ;INTO RIGHT HALF
INDEX6: ADDM A,BUFR1
MOVNS A
ADDM A,BUFR2
INDEX7: POP P,LSTBLK ;STORE THIS AS LAST BLOCK READ
JRST LOAD1
INDEX3: HRRE A,T ;GET BLOCK # OF NEXT INDEX
JUMPL A,EOF ;FINISHED IF -1
PUSH P,T ;STACK THIS BLOCK
HRRZ T,LSTBLK ;GET LAST BLOCK
JRST NXTNDX ;CHECK IF NEXT BUFFER IN CORE
INDEX: IN 1, ;GET NEXT BUFFER
SOSA BUFR2 ;O.K. RETURN, BUT 1 WORD TOO MANY
JRST WORD3 ;ERROR OR EOF
PUSHJ P,WORD ;READ FIRST WORD
INDEXE: TRZE F,XFLG ;INDEX IN CORE?
TTCALL 3,[ASCIZ /LIBRARY INDEX INCONSISTENT - CONTINUING
/] ;WARNING MESSAGE
JRST LOAD1A+1 ;AND CONTINUE
>
SUBTTL ALGOL OWN BLOCK (TYPE 15)
IFN ALGSW,<
ALGBLK:
IFN SAILSW,<TRNN F,ALGFL ;IF NOT ALGOL
JRST LDPRG ;MUST BE SAIL BLOCK TYPE 15>
PUSHJ P,RWORD ;READ 3RD WORD
HLRZ V,W ;GET START OF OWN BLOCK
MOVEI C,(W) ;GET LENGTH OF OWN BLOCK
MOVEM C,OWNLNG ;SAVE IT TO FIX RELOC AT END
PUSHJ P,ALGB2 ;FIX AND CHECK PROG BREAK
ADDI V,(R) ;RELOCATE
MOVEI W,(V) ;GET CURRENT OWN ADDRESS
EXCH W,%OWN ;SAVE FOR NEXT TIME
MOVEM W,@X ;STORE LAST OWN ADDRESS IN LEFT HALF
ALGB1: PUSHJ P,RWORD ;GET DATA WORD
HLRZ V,W ;GET ADDRESS TO FIX UP
HRRZS W ;RIGHT HALF ONLY
ADD W,%OWN ;ADD IN ADDRESS OF OWN BLOCK
ADDM W,@X ;FIX UP RIGHT HALF
JRST ALGB1 ;LOOP TIL DONE
ALGNAM: JUMPE W,CPOPJ ;NOT ALGOL MAIN PROG
TROE F,ALGFL ;SET ALGOL SEEN FLAG
JRST ALGER1 ;ONLY ONE ALGOL MAIN PROG ALLOWED
IFN REENT,<TRNN F,SEENHI ;ANYTHING IN HIGH SEGMENT?>
CAME R,[XWD W,JOBDA] ;ANYTHING LOADED IN LOW SEGMENT?
JRST ALGER2 ;YES, ERROR ALSO
SETZM %OWN ;INITIALISE OWN AREA POINTER
IFN REENT,<TRO F,VFLG ;DEFAULT RE-ENTRANT OP-SYSTEM>
ALGB2: ADDI H,(W) ;FIX PROG BREAK
IFN REENT,<CAML H,HILOW
MOVEM H,HILOW ;HIGHEST LOW CODE LOADED>
CAILE H,1(S) ;SKIP IF SUFFICIENT CORE AVAILABLE
IFN EXPAND,<JRST [PUSHJ P,XPAND>
JRST FULLC
IFN EXPAND,< JRST .+1]>
POPJ P,
ALGER1: ERROR ,</ONLY ONE ALGOL MAIN PROGRAM ALLOWED#/>
JRST LD2
ALGER2: ERROR ,</ALGOL MAIN PROGRAM MUST BE LOADED FIRST#/>
JRST LD2
>
SUBTTL SAIL BLOCK TYPE 15
COMMENT * BLOCK TYPE 15 AND 16. SIXBIT FOR FIL,PPN,DEV
IN THE BLOCK. SEARCH TABLE FOR ALREADY REQUESTED. IF NOT
ENTER REQUEST. ORIGINAL CODE BY DCS REWRITTEN BY WFW*
IFN SAILSW,<
IFE ALGSW<ALGBLK:>
LDPRG: MOVEI D,PRGFLS-1 ;SET UP SOMETHING WE CAN SEARCH WITH
MOVE W,PRGPNT ;AND CURRENT POINTER
PUSHJ P,LDSAV ;GO ENTER (WILL NOT RETURN IF RUNS OUT)
MOVEM D,PRGPNT
JRST LDPRG ;BACK FOR MORE
LDLIB: MOVEI D,LIBFLS-1
MOVE W,LIBPNT
PUSHJ P,LDSAV
MOVEM D,LIBPNT
JRST LDLIB ;LOOKS JUST LIKE THE LAST ONE, DOESN'T IT
LDSAV: HRLI D,-RELLEN-1 ;GET AOBJN SET UP
MOVEM W,LODPN2# ;SAV IT
PUSHJ P,PRWORD ;GET FILE,PPN
MOVE A,W ;SAVE ONE
PUSHJ P,RWORD ;AND DEVICE
FILSR: CAMN D,LODPN2
JRST FENT ;HAVE GOTTEN THERE, ENTER FILE
CAME C,PRGFIL(D) ;CHECK FOR MATCH
JRST NOMT ;NOT FILE
CAME A,PRGPPN(D)
JRST NOMT ;NO PPN
CAME W,PRGDEV(D)
NOMT: AOBJN D,FILSR ;AND NOT DEVICE SHOULD ALWAYS JUMP
MOVE D,LODPN2
POPJ P, ;JUST RETURN CURRENT POINTER
FENT: MOVE D,LODPN2 ;ENTER IT
AOBJP D,WRONG ;THAT IS IF NOT TOO MANY
MOVEM C,PRGFIL-1(D) ;HAVE ALREADY INDEXED
MOVEM A,PRGPPN-1(D) ;HENCE THE -1
MOVEM W,PRGDEV-1(D)
POPJ P,
WRONG: ERROR ,</TOO MANY DEMANDED FILES#/>
JRST LD2
>
SUBTTL SYMBOL TABLE SEARCH SUBROUTINES
; ENTERED WITH SYMBOL IN C
; RETURN IS WITH POINTER IN A IF MATCHING SYMBOL FOUND
; OTHERWISE, A SKIP ON RETURN OCCURS
SREQ: JUMPGE S,CPOPJ1 ;JUMP IF NO UNDEF. SYMBOLS
SKIPA A,S ;LOAD REQUEST SEARCH POINTER
SDEF: MOVE A,B ;LOAD DEF. SYMBOL SEARCH POINTER
SDEF1: CAMN C,1(A)
POPJ P, ;SYMBOLS MATCH, RETURN
IFE K,< TLNE N,F4SW ;ARE WE IN FORTRAN?
JRST SDEF2 ;YES,JUST TRY NEXT SYMBOL>
TLC C,400000 ;MIGHT BE SUPPRESSED INTERNAL
CAMN C,1(A) ;WAS IT?
JRST [TLO C,400000 ;YES, SO ENSURE IT'S SUPPRESSED
MOVEM C,1(A) ;STORE SUPPRESSED DEFINITION
POPJ P,] ;YES
TLC C,400000 ;NO,TRY NEXT SYMBOL
SDEF2: ADD A,SE3
JUMPL A,SDEF1
IFE K,< JRST CPOPJ1 ;SYMBOL NOT FOUND SKIPS ON RETURN>
IFN K,<
CPOPJ1: AOS (P)
POPJ P,>
SUBTTL RELOCATION AND BLOCK INPUT
PRWORD: PUSHJ P,RWORD ;READ A WORD PAIR
MOVE C,W ;LOAD C WITH FIRST DATA WORD
TRNE E,377777 ;TEST FOR END OF BLOCK
JRST RWORD1 ;INPUT SECOND WORD OF PAIR
MOVEI W,0 ;NO SECOND WORD, ASSUME ZERO
POPJ P,
RWORD: TRNN E,377777 ;TEST FOR END OF BLOCK
JRST LOAD1 ;RETURN TO LOAD THE NEXT BLOCK
RWORD1: AOBJN E,RWORD2 ;JUMP IF DATA WORD NEXT
PUSHJ P,WORD ;READ CONTROL WORD
MOVE Q,W ;DON'T COUNT RELOCATION WORDS
HRLI E,-22 ;SET RELOCATION WORD BYTE COUNT
RWORD2: PUSHJ P,WORD ;READ INPUT WORD
JUMPGE Q,RWORD3 ;TEST LH RELOCATION BIT
TRNN F,TWOFL ;POSSIBLE TWO SEGMENTS?
JRST RWORD5 ;NO
MOVSS W
PUSHJ P,CHECK ;USE CORRECT RELOCATION
HRRI W,@R
MOVSS W
JRST RWORD3 ;AND TEST RIGHT HALF
RWORD5: HRLZ T,R
ADD W,T ;LH RELOCATION
RWORD3: TLNN Q,200000 ;TEST RH RELOCATION BIT
JRST RWORD4 ;NOT RELOCATABLE
TRNE F,TWOFL ;POSSIBLE TWO SEGMENTS?
PUSHJ P,CHECK ;USE CORRECT RELOCATION
HRRI W,@R ;RH RELOCATION
RWORD4: LSH Q,2
POPJ P,
CHECK: MOVE T,HVAL1 ;START OF HISEGMENT
CAIG T,NEGOFF(W) ;IN HISEG?
JRST [SUBI W,(T) ;YES REMOVE OFSET
POPJ P,]
HRRI W,@LOWR ;USE LOW SEG RELOC
JRST CPOPJ1 ;SKIP RETURN
SUBTTL PRINT STORAGE MAP SUBROUTINE
PRMAP: CAIN D,1 ;IF /1M PRINT LOCAL SYMBOLS
TROA F,LOCAFL ;YES,TURN ON FLAG
TRZ F,LOCAFL ;CLEAR JUST IN CASE
PUSHJ P,FSCN1 ;LOAD OTHER FILES FIRST
PUSHJ P,CRLFLF ;START NEW PAGE
HRRZ W,R
IFN REENT,<CAIG W,JOBDA ;LOADED INTO LOW SEGMENT
JRST NOLOW ;DON'T PRINT IF NOTHING THERE>
PUSHJ P,PRNUM0
IFE REENT,<ERROR 7,<?IS THE PROGRAM BREAK@?>>
IFN REENT,<ERROR 7,<?IS THE LOW SEGMENT BREAK@?>
PUSHJ P,CRLF ;CR-LF ON ALL BUT TTY
NOLOW: MOVE W,HVAL ;HISEG BREAK
CAMG W,HVAL1 ;HAS IT CHANGED
JRST NOHIGH ;NO HI-SEGMENT
TLO F,FCONSW ;FORCE OUT HI-SEG BREAK ALSO
PUSHJ P,PRNUM0
ERROR 7,<?IS THE HIGH SEGMENT BREAK@?>
PUSHJ P,CRLF
NOHIGH:>
IFE NAMESW,< MOVE W,DTOUT ;OUTPUT NAME >
IFN NAMESW,< SKIPN W,DTOUT
MOVE W,CURNAM ;USE PROGRAM NAME>
JUMPE W,.+3 ;DON'T PRINT IF NOT THERE
PUSHJ P,PWORD
PUSHJ P,SPACES ;SOME SPACES
ERROR 0,<?STORAGE MAP!?>
PUSHJ P,SPACES ;SOME SPACES
PUSH P,N
PUSH P,E
MOVE N,[POINT 6,DBUF] ;INITIALIZE DATE POINTER
MSTIME Q, ;GET THE TIME
IDIVI Q,↑D60*↑D1000
IDIVI Q,↑D60
PUSH P,A ;SAVE MINUTES
PUSHJ P,OTOD1 ;STORE HOURS
POP P,Q ;GET MINUTES
PUSHJ P,OTOD ;STORE MINUTES
DATE E, ;GET DATE
IDIVI E,↑D31 ;GET DAY
ADDI Q,1
PUSHJ P,OTOD ;STORE DAY
IDIVI E,↑D12 ;GET MONTH
ROT Q,-1 ;DIV BY 2
HRR A,DTAB(Q) ;GET MNEMONIC
TLNN Q,400000
HLR A,DTAB(Q) ;OTHER SIDE
HRRM A,DBUF+1 ;STORE IT
MOVEI Q,↑D64(E) ;GET YEAR
MOVE N,[POINT 6,DBUF+2]
PUSHJ P,OTOD ;STORE IT
POP P,E
POP P,N
PUSHJ P,DBUF1
PUSHJ P,CRLF
SKIPN STADDR ;PRINT STARTING ADDRESS
JRST NOADDR ;NO ADDRESS SEEN
ERROR 0,</STARTING ADDRESS !/>
PUSHJ P,SP1
MOVE W,STADDR ;GET ST. ADDR.
PUSHJ P,PRNUM0 ;PRINT IT
IFN NAMESW,<
PUSHJ P,SP1
MOVE W,[SIXBIT / PROG /]
PUSHJ P,PWORD
MOVE W,CURNAM ;PROG NAME
PUSHJ P,PWORD
PUSHJ P,SP1
MOVE W,ERRPT6 ;SIXBIT / FILE /
PUSHJ P,PWORD
MOVE W,PRGNAM ;FILE NAME
PUSHJ P,PWORD>
NOADDR: IFN REENT,<
HRRZ A,HVAL1 ;GET INITIAL HIGH START
ADDI A,JOBHDA ;ADD IN OFFSET
HRLI A,JOBDA ;LOW START
MOVSM A,SVBRKS ;INITIAL BREAKS>
HLRE A,B
MOVNS A
ADDI A,(B)
PRMAP1: SUBI A,2
IFN REENT,<SKIPN C,1(A) ;LOAD SYMBOL SKIP IF REAL SYMBOL
JRST PRMAP4 ;IGNORE ZERO NAME(TWOSEG BREAKS)>
IFE REENT,<MOVE C,1(A) ;LOAD SYMBOL>
TLNN C,300000 ;TEST FOR LOCAL SYMBOL
JRST .+4 ;GLOBAL (NOT LOCAL ANYWAY)
TRNN F,LOCAFL ;PRINT LOCAL SYMBOLS?
JRST PRMAP4 ;IGNORE LOCAL SYMBOLS
TLC C,140000 ;MAKE IT LOOK LIKE INTERN
TLNE C,040000
JRST PRMP1A
PUSHJ P,CRLF
PUSHJ P,CRLF
SETZM TABCNT
JRST PRMP1B
PRMP1A: PUSHJ P,TAB
PRMP1B: PUSHJ P,PRNAM1 ;PRINT SYMBOL AND VALUE
TLNE C,040000
JRST PRMAP4 ;GLOBAL SYMBOL
HLRE C,W ;POINTER TO NEXT PROG. NAME
HRRZS W ;SO WE ONLY HAVE THE HALF WE WANT
PRMAP7: JUMPL C,PRMP7A
IFN REENT,<SKIPN 1(B) ;IS IT A ZERO SYMBOL
JRST [MOVE C,B ;SET UP C
JRST PRMAP2] ;AND GO
HRRZ T,HVAL ;GET TO OF HI PART
CAML W,HVAL1 ;IS PROGRAM START UP THERE??
JRST PRMAP6 ;YES
HRRZ T,HILOW ;GET HIGHEST LOCATION LOADED IN LOW
SUBI T,(X) ;REMOVE OFFSET
CAIE T,(W) ;EQUAL IF ZERO LENGTH PROG>
HRRZ T,R ;GET LOW, HERE ON LAST PROG
JRST PRMAP6 ;GO
PRMP7A: ADDI C,2(A) ;POINTER TO NEXT PROGRAM NAME
PRMAP2: IFN REENT,<
SKIPE 1(C) ;THIS IS A TWO SEG FILE
JRST PRMP2A ;NO
MOVE T,2(C) ;GET PROG BREAKS
TLNN T,-1 ;IF NO HIGH STUFF YET
HLL T,SVBRKS ;FAKE IT
SUB T,SVBRKS ;SUBTRACT LAST BREAKS
HRRZ W,T ;LOW BREAK
PUSH P,W ;SAVE IT
JUMPGE T,.+2 ;IF NEGATIVE
TDZA W,W ;MAKE ZERO (FIRST TIME THRU)
HLRZ W,T ;GET HIGH BREAK
PUSHJ P,PRNUM ;PRINT IT
PUSHJ P,TAB ;AND TAB
POP P,W ;LOW BREAK
PUSHJ P,PRNUM
MOVE T,2(C)
CAMN C,B ;EQUAL IF LAST PROG
SETZ C, ;SIGNAL END
TLNN T,-1
HLL T,SVBRKS
CAMN T,SVBRKS ;ZERO LENGTT IF EQUAL
JRST PRMP6A ;SEE IF LIST ALL ON
MOVEM T,SVBRKS ;SAVE FOR NEXT TIME
JRST PRMAP3 ;AND CONTINUE
PRMP2A:>
HRRZ T,(C) ;GET ITS STARTING ADRESS
IFN REENT,<CAMGE W,HVAL1 ;MAKE SURE BOTH IN SAME SEGMENT
CAMGE T,HVAL1
CAMGE T,W
JRST [HLRE T,(C) ;NO TRY NEXT ONE DOWN
JUMPE T,@PRMAP7 ;END GO USE PROG BREAK
ADDI C,(T)
JRST PRMAP2] ;CHECK THIS ONE>
PRMAP6: SUBM T,W ;SUBTRACT ORIGIN TO GET LENGTH
PUSHJ P,PRNUM ;PRINT PROGRAM LENGTH
PUSHJ P,CRLF
PRMP6A: TLNN N,ALLFLG ;SKIP IF LIST ALL MODE IS ON
TRNE W,777777 ;SKIP IF ZERO LENGTH PROGRAM
JRST PRMAP3
HLRE C,2(A) ;GET BACK CORRECT LOCATION IF 0 LENGTH
JUMPE C,PRMAP5 ;JUMP IF LAST PROGRAM
ADDI C,2(A) ;IN CASE WE SKIPPED SOME PROGRAMS
SKIPA A,C ;SKIP GLOBALS, ZERO LENGTH PROG.
PRMAP3: PUSHJ P,CRLF
PRMAP4: CAILE A,(B) ;TEST FOR END OF SYMBOL TABLE
JRST PRMAP1
PRMAP5: PUSHJ P,CRLF ;GIVE AN XTRA CR-LF
SUBTTL LIST UNDEFINED AND MULTIPLY DEFINED GLOBALS
PUSHJ P,PMS1 ;PRINT UNDEFINED SYMBOLS
;LIST NUMBER OF MULTIPLY DEFINED GLOBALS
PMS3: SKIPN W,MDG ;ANY MULTIPLY DEFINED GLOBALS
JRST PMS4 ;NO, EXCELSIOR
PUSHJ P,FCRLF ;ROOM AT THE TOP
PUSHJ P,PRQ ;PRINT ?
PUSHJ P,PRNUM0 ;NUMBER OF MULTIPLES
ERROR 7,<?MULTIPLY DEFINED GLOBALS@?>
PMS4: TLNE N,AUXSWE ;AUXILIARY OUTPUT DEVICE?
OUTPUT 2, ;INSURE A COMPLETE BUFFER
POPJ P, ;RETURN
;LIST UNDEFINED GLOBALS
PMS1: PUSHJ P,FSCN1 ;LOAD FILES FIRST
JUMPGE S,CPOPJ ;JUMP IF NO UNDEFINED GLOBALS
PUSHJ P,FCRLF ;START THE MESSAGE
HLRE W,S ;COMPUTE NO. OF UNDEF. GLOBALS
MOVMS W
LSH W,-1 ;<LENGTH OF LIST>/2
PUSHJ P,PRNUM0
ERROR 7,</UNDEFINED GLOBALS@/>
MOVE A,S ;LOAD UNDEF. POINTER
PMS2: SKIPL W,1(A)
TLNN W,40000
JRST PMS2A
PUSHJ P,FCRLF
PUSHJ P,PRNAM0 ;PRINT SYMBOL AND POINTER
PMS2A: ADD A,SE3
JUMPL A,PMS2
CPOPJ: POPJ P,
PMS: PUSHJ P,PMS1 ;PRINT UNDEFINED SYMBOLS
JUMPGE S,CPOPJ ;NO UNDEFINED SYMBOLS
PUSHJ P,CRLF ;NEW LINE,MAKE ? VISIBLE
PUSHJ P,PRQ ;FIX FOR BATCH TO PRINT ALL SYMBOLS
JRST CRLF ;SPACE AFTER LISTING
SUBTTL ENTER FILE ON AUXILIARY OUTPUT DEVICE
IAD2: PUSH P,A ;SAVE A FOR RETURN
MOVE A,LD5C1 ;GET AUX. DEV.
DEVCHR A, ;GET DEVCHR
TLNN A,4 ;DOES IT HAVE A DIRECTORY
JRST IAD2A ;NO SO JUST RETURN
MOVE A,DTOUT ;GET OUTPUT NAME
CAME A,[SIXBIT /JOBDAT/] ;DON'T USE JOBDAT
JUMPN A,IAD2A ;USE ANYTHING NON-ZERO
MOVSI A,(SIXBIT /DSK/) ;DEFAULT DEVICE
CAMN A,LD5C1 ;IS IT AUX. DEV.
JRST .+5 ;YES LEAVE WELL ALONE
CLOSE 2, ;CLOSE OLD AUX. DEV.
MOVEM A,LD5C1 ;SET IT TO DSK
OPEN 2,OPEN2 ;OPEN IT FOR DSK
JRST IMD4 ;FAILED
IFN NAMESW,< SKIPN A,CURNAM ;USE PROG NAME>
MOVSI A,(SIXBIT /MAP/) ;AN UNLIKELY NAME
MOVEM A,DTOUT ;SO ENTER WILL NOT FAIL
IAD2A: POP P,A ;RECOVER A
SETZM DTOUT+2 ;CLEAR PROTECTION (LEVEL D)
ENTER 2,DTOUT ;WRITE FILE NAME IN DIRECTORY
JRST IMD3 ;NO MORE DIRECTORY SPACE
POPJ P,
IMD3: ERROR ,</DIR. FULL@/>
JRST LD2
IMD4: MOVE P,[XWD -40,PDLST] ;RESTORE STACK
TLZ N,AUXSWE!AUXSWI ;NO AUX.DEV.NOW
ERROR ,</NO MAP DEVICE@/>
JRST PRMAP5 ;CONTINUE TO LOAD
SUBTTL PRINT SUBROUTINES
;PRINT THE 6 DIGIT OCTAL ADDRESS IN W
; ACCUMULATORS USED: D,T,V
PRNAM0: MOVE C,1(A) ;LOAD SYMBOL
PRNAM1: MOVE W,2(A) ;LOAD VALUE
PRNAM: PUSHJ P,PRNAME
PRNUM:
TRNN F,TTYFL
PUSHJ P,SP1
PUSHJ P,SP1
PRNUM0: MOVE V,PRNUM2 ;LOAD BYTE POINTER TO RH. OF W
MOVNI D,6 ;LOAD CHAR. COUNT
PRNUM1: ILDB T,V ;LOAD DIGIT TO BE OUTPUT
ADDI T,60 ;CONVERT FROM BINARY TO ASCII
PUSHJ P,TYPE2
AOJL D,PRNUM1 ;JUMP IF MORE DIGITS REMAIN
POPJ P,
PRNUM2: XWD 220300,W
IFN NAMESW,<
LDNAM: MOVE T,[POINT 6,CURNAM] ;POINTER
MOVNI D,6 ;SET COUNT
TLZ W,740000 ;REMOVE CODE BITS
SETNAM: IDIVI W,50 ;CONVERT FROM RAD 50
HRLM C,(P)
AOJGE D,.+2
PUSHJ P,SETNAM
HLRZ C,(P)
JUMPE C,INAM
ADDI C,17
CAILE C,31
ADDI C,7
CAIG C,72 ;REMOVE SPECIAL CHARS. (. $ %)
IDPB C,T
INAM: POPJ P, >
;YE OLDE RECURSIVE NUMBER PRINTER
;PRINTS Q, WITH LEADING ZEROES SUPPRESSED; USES A AND T
RCNUM: IDIVI Q,12 ;RADIX DECIMAL
ADDI A,"0"
HRLM A,(P)
JUMPE Q,.+2
PUSHJ P,RCNUM
HLRZ T,(P)
JRST TYPE2
SPACES: PUSHJ P,SP1
SP1: PUSHJ P,SPACE
SPACE: MOVEI T,40
JRST TYPE2
; ACCUMULATORS USED: Q,T,D
PWORD: MOVNI Q,6 ;SET CHARACTER COUNT TO SIX
PWORD1: MOVE D,LSTPT ;ENTER HERE WITH Q PRESET
PWORD2: ILDB T,D ;LOAD NEXT CHAR. TO BE OUTPUT
PUSHJ P,TYPE ;OUTPUT CHARACTER
AOJL Q,PWORD2
POPJ P,
;TYPEOUT SUBROUTINE - THE CHARACTER SUPPLIED IN T IS CONVERTED TO ASCII
;AND IS OUTPUT ON THE CONSOLE AND/OR THE SPECIFIED LOADER MAP OUTPUT
;DEVICE
CRLFLF: PUSHJ P,CRLF
FCRLF: TLO F,FCONSW ;INSURE TTY OUTPUT
CRLF: MOVEI T,15 ;CARRIAGE RETURN LINE FEED
PUSHJ P,TYPE2
TRCA T,7 ;CR.XOR.7=LF
TYPE: MOVEI T,40(T) ;CONVERT SIXBIT TO ASCII
TYPE2: TLNN N,AUXSWI ;IS THER AN AUXILIARY DEVICE?
JRST TYPE3 ;NO, DONT OUTPUT TO IT
TLON N,AUXSWE ;IS AUX. DEV. ENTERED?
PUSHJ P,IAD2 ;NOPE, DO SO!
SOSG ABUF2 ;SPACE LEFT IN BUFFER?
OUTPUT 2, ;CREATE A NEW BUFFER
IDPB T,ABUF1 ;DEPOSIT CHARACTER
TLNN F,FCONSW ;FORCE OUTPUT TO CONSOLE TOO?
POPJ P, ;NOPE
TYPE3: IFN RPGSW,<
TRNE F,NOTTTY ;IF TTY IS ANOTHER DEVICE
POPJ P, ;DON'T OUTPUT TO IT>
SKIPN BUFO2 ;END OF BUFFER
OUTPUT 3, ;FORCE OUTPUT NOW
IDPB T,BUFO1 ;DEPOSIT CHARACTER
CAIN T,12 ;END OF LINE
OUTPUT 3, ;FORCE AN OUTPUT
POPJ P,
SUBTTL SYMBOL PRINT - RADIX 50
; ACCUMULATORS USED: D,T
PRNAME: MOVE T,C ;LOAD SYMBOL
TLZ T,740000 ;ZERO CODE BITS
PUSH P,T
PUSH P,C
MOVEI C,6
MOVEI D,1
IDIVI T,50
JUMPN V,.+2
IMULI D,50
SOJN C,.-3
POP P,C
POP P,T
IMUL T,D
MOVNI D,6 ;LOAD CHAR. COUNT
SPT: IDIVI T,50 ;THE REMAINDER IS THE NEXT CHAR.
HRLM V,(P) ;STORE IN LH. OF PUSHDOWN LIST
AOJGE D,.+2 ;SKIP IF NO CHARS. REMAIN
PUSHJ P,SPT ;RECURSIVE CALL FOR NEXT CHAR.
HLRZ T,(P) ;LOAD FROM LH. OF PUSHDOWN LIST
JUMPE T,TYPE ;BLANK
ADDI T,60-1
CAILE T,71
ADDI T,101-72
CAILE T,132
SUBI T,134-44
CAIN T,43
MOVEI T,56
JRST TYPE2
TAB1: SETZM TABCNT
PUSHJ P,CRLF
TAB: AOS T,TABCNT
CAIN T,5
JRST TAB1
TRNE F,TTYFL
JRST SP1
MOVEI T,11
JRST TYPE2
OTOD: IBP N
OTOD1: IDIVI Q,↑D10
ADDI Q,20 ;FORM SIXBIT
IDPB Q,N
ADDI A,20
IDPB A,N
POPJ P,
DTAB: SIXBIT /JANFEB/
SIXBIT /MARAPR/
SIXBIT /MAYJUN/
SIXBIT /JULAUG/
SIXBIT /SEPOCT/
SIXBIT /NOVDEC/
SUBTTL ERROR MESSAGE PRINT SUBROUTINE
; FORM OF CALL:
; JSP A,ERRPT
; SIXBIT /<MESSAGE>/
; ACCUMULATORS USED: T,V,C,W
ERRPT: TLO F,FCONSW ;INSURE TTY OUTPUT
PUSHJ P,CRLF ;ROOM AT THE TOP
PUSHJ P,PRQ ;START OFF WITH ?
ERRPT0: PUSH P,Q ;SAVE Q
SKIPA V,ERRPT5
ERRPT1: PUSHJ P,TYPE
ILDB T,V
CAIN T,"@"-40
JRST ERRPT4
CAIN T,"%"-40
JRST ERRPT9
CAIN T,"!"-40
JRST ERRP42 ;JUST RETURN,LEAVE FCONSW ON
CAIE T,"#"-40
JRST ERRPT1
SKIPN C,DTIN
JRST ERRPT4
MOVNI Q,14
MOVEI W,77
ERRPT2: TDNE C,W
JRST ERRPT3
LSH W,6
AOJL Q,ERRPT2
ERRPT3: MOVE W,ERRPT6
PUSHJ P,PWORD1
SKIPN W,DTIN1
JRST ERRPT4
LSH W,-6
TLO W,160000
MOVNI Q,4
PUSHJ P,PWORD1
ERRPT4: PUSHJ P,CRLF
ERRP41: TLZ F,FCONSW ;ONE ERROR PER CONSOLE
ERRP42: POP P,Q ;***DMN*** FIX FOR ILC MESSAGE
AOJ V, ;PROGRAM BUMMERS BEWARE:
JRST @V ;V HAS AN INDEX OF A
ERRPT5: POINT 6,0(A)
ERRPT6: SIXBIT / FILE /
ERRPT8: TLO F,FCONSW ;INSURE TTY OUTPUT
PUSHJ P,PRQ ;START WITH ?
CAIGE T,140 ;IS IT A NON-PRINTING CHAR?
CAIL T,40
JRST ERRP8
PUSH P,T
MOVEI T,136 ;UP ARROW
PUSHJ P,TYPE2
POP P,T
TRC T,100 ;CONVERT TO PRINTING CHAR.
ERRP8: PUSHJ P,TYPE2
ERRPT7: PUSHJ P,SPACE
JRST ERRPT0
ERRPT9: MOVEI V,@V
PUSH P,V
ERROR 7,<?ILLEGAL -LOADER@?>
POP P,V
JRST ERRP41
;PRINT QUESTION MARK
PRQ: PUSH P,T ;SAVE
MOVEI T,"?" ;PRINT ?
PUSHJ P,TYPE2 ;...
POP P,T ;RESTORE
POPJ P, ;RETURN
SUBTTL INPUT - OUTPUT INTERFACE
;BINARY INPUT SUBROUTINE - RETURNS A WORD IN W
IFE K,<
WORDPR: PUSHJ P,WORD ;GET FIRST WORD OF PAIR
MOVE C,W ;KEEP IT HANDY>
WORD: SOSGE BUFR2 ;SKIP IF BUFFER NOT EMPTY
JRST WORD2
WORD1: ILDB W,BUFR1 ;PICK UP 36 BIT WORD
POPJ P,
WORD2: IN 1, ;GET NEXT BUFFER LOAD
JRST WORD ;DATA OK - CONTINUE LOADING
WORD3: STATZ 1,IODEND ;TEST FOR EOF
JRST EOF ;END OF FILE EXIT
ERROR ,< /INPUT ERROR#/>
JRST LD2 ;GO TO ERROR RETURN
SE3: XWD 2,2 ;SYMBOL POINTER INCREMENT
PDLPT: XWD -41,PDLST-1; INITIAL PUSHDOWN POINTER
COMM: SQUOZE 0,.COMM.
LSTPT: POINT 6,W ;CHARACTER POINTER TO W
IOBKTL==40000
IOIMPM==400000
IODERR==200000
IODTER==100000
IODEND==20000
IOBAD==IODERR!IODTER!IOBKTL!IOIMPM
SUBTTL IMPURE CODE
IFN SEG2SW,< RELOC
LOWCOD: RELOC>
IFN PURESW,<HICODE:
IFN SEG2SW,< PHASE LOWCOD>
IFE SEG2SW,< PHASE 140>>
DBUF1: JSP A,ERRPT7
DBUF: SIXBIT /TI:ME DY-MON-YR @/
POPJ P,
;DATA FOR PURE OPEN UUO'S
IFN SPCHN,<
CHNENT: 0
SIXBIT .CHN.
0
0
CHNOUT: 17
SIXBIT /DSK/
0
>
IFN RPGSW,<
OPEN1: EXP 1
RPG1: Z
XWD 0,CTLIN
>
OPEN2: EXP 1
LD5C1: Z
XWD ABUF,0
OPEN3: EXP 14
ILD1: Z
XWD 0,BUFR
IFN PURESW,<DEPHASE
CODLN=.-HICODE>
SUBTTL DATA STORAGE
IFN PURESW,<
IFE SEG2SW,<LOC 140>
IFN SEG2SW,<RELOC>
LOWCOD: BLOCK CODLN>
PDSAV: BLOCK 1 ;SAVED PUSHDOWN POINTER
COMSAV: BLOCK 1 ;LENGTH OF COMMON
MDG: BLOCK 1 ;COUNTER FOR MUL DEF GLOBALS
PDLST: BLOCK 40
F.C: BLOCK 1
BLOCK 1 ;STORE N HERE
BLOCK 1 ;STORE X HERE
BLOCK 1 ;STORE H HERE
BLOCK 1 ;STORE S HERE
BLOCK 1 ;STORE R HERE
B.C: BLOCK 1
STADDR: BLOCK 1 ;HOLDS STARTING ADDRESS
IFN NAMESW,<
PRGNAM: BLOCK 1 ;STORE BINARY FILE NAME-USED TO MAKE SYSTAT MORE MEANINGFUL
>
IFN REENT,<
IFN STANSW,<
PRGCRD: BLOCK 1 ;SAVE DATE & TIME FOR SETCRD UUO>
HIGHX: BLOCK 1
HIGHR: BLOCK 1 ;HOLD X AND R WHILE LOADING LOW SEG PIECES
LOWX: BLOCK 1
HILOW: BLOCK 1 ;HIGHEST NON-BLOCK STMT IN LOW SEG
HVAL: BLOCK 1 ;ORG OF HIGH SEG>
HVAL1: BLOCK 1 ;ACTUAL ORG OF HIGH SEG
LOWR: BLOCK 1 ;HOLD X AND R WHILE LOADING HISEG PIECES
IFN KUTSW,<CORSZ: BLOCK 1>
IFN DMNSW,<KORSP: BLOCK 1>
IFN LDAC,<BOTACS: BLOCK 1>
IFN WFWSW,<VARLNG: BLOCK 1
VARREL: BLOCK 1>
IFN SAILSW,<LIBFLS: BLOCK RELLEN*3
PRGFLS: BLOCK RELLEN*3>
PT1: BLOCK 1
SVA: BLOCK 1
IFN RPGSW,<
NONLOD: BLOCK 1
SVRPG: BLOCK 1
IFN TEMP,<
TMPFIL: BLOCK 2
TMPFLG: BLOCK 1>
>
IFN NAMESW,<
CURNAM: BLOCK 1
>
IFN PP,<
OLDDEV: BLOCK 1
PPN: BLOCK 1
PPNE: BLOCK 1
PPNV: BLOCK 1
PPNW: BLOCK 1
>
IFN FAILSW,<
GLBCNT: BLOCK 1
HDSAV: BLOCK 1
HEADNM: BLOCK 1
LFTHSW: BLOCK 1
OPNUM: BLOCK 1
POLSW: BLOCK 1
SVHWD: BLOCK 1
SVSAT: BLOCK 1
PPDB: BLOCK PPDL+1
LINKTB: BLOCK 21
>
HISTRT: BLOCK 1 ;JOBREL AT START OF LOADING
IFN L,<
LSPXIT: BLOCK 1
LSPREL: BLOCK 1 ; BY DBA AFTER JRA FOR UCI
RINITL: BLOCK 1
OLDJR: BLOCK 1>
IFN SPCHN,<
CHNTAB: BLOCK 1
BEGOV: BLOCK 1
CHNACN: BLOCK 1
CHNACB: BLOCK 1>
TABCNT: BLOCK 1
LIMBO: BLOCK 1 ;WHERE OLD CHARS. ARE STORED
IFN DIDAL,<LSTBLK: BLOCK 1 ;POINTER TO LAST PROG LOADED>
IFN EXPAND,<ALWCOR: BLOCK 1 ;CORE AVAILABLE TO USER>
IFN ALGSW,<%OWN: BLOCK 1 ;ADDRESS OF ALGOL OWN AREA
OWNLNG: BLOCK 1 ;LENGTH OF OWN BLOCK>
IFN REENT,<SVBRKS: BLOCK 1 ;XWD HIGH,LOW (PROG BREAKS)>
SUBTTL BUFFER HEADERS AND HEADER HEADERS
BUFO: BLOCK 1 ;CONSOLE INPUT HEADER HEADER
BUFO1: BLOCK 1
BUFO2: BLOCK 1
BUFI: BLOCK 1 ;CONSOLE OUTPUT HEADER HEADER
BUFI1: BLOCK 1
BUFI2: BLOCK 1
ABUF: BLOCK 1 ;AUXILIARY OUTPUT HEADER HEADER
ABUF1: BLOCK 1
ABUF2: BLOCK 1
BUFR: BLOCK 1 ;BINARY INPUT HEADER HEADER
BUFR1: BLOCK 1
BUFR2: BLOCK 1
DTIN: BLOCK 1 ;DECTAPE INPUT BLOCK
DTIN1: BLOCK 3
DTOUT: BLOCK 1 ;DECTAPE OUTPUT BLOCK
DTOUT1: BLOCK 3
TTYL==52 ;TWO TTY BUFFERS
IFN STANSW,< TTYL==70 ;;;STANFORD, JUST TO BE DIFFERENT, HAS BIG TTY BFRS>
IFE LNSSW,<
IFE K,< BUFL==406 ;TWO DTA BUFFERS FOR LOAD>
IFN K,< BUFL==203 ;ONE DTA BUFFER FOR LOAD>
ABUFL==203 ;ONE DTA BUFFER FOR AUX DEV>
IFN LNSSW,<
IFE K,<BUFL==4*203+1>
IFN K,<BUFL==203+1>
ABUFL==2*203+1>
TTY1: BLOCK TTYL ;TTY BUFFER AREA
BUF1: BLOCK BUFL ;LOAD BUFFER AREA
AUX: BLOCK ABUFL ;AUX BUFFER AREA
IFN RPGSW,<
CTLIN: BLOCK 3
CTLNAM: BLOCK 3
CTLBUF: BLOCK 203+1
>
SUBTTL FORTRAN DATA STORAGE
IFN STANSW,<PATCH: BLOCK 20 ;STANFORD HAS SEMI-INFINITE CORE>
IFE K,<
TOPTAB: BLOCK 1 ;TOP OF TABLES
CTAB: BLOCK 1; COMMON
ATAB: BLOCK 1; ARRAYS
STAB: BLOCK 1; SCALARS
GSTAB: BLOCK 1; GLOBAL SUBPROGS
AOTAB: BLOCK 1; OFFSET ARRAYS
CCON: BLOCK 1; CONSTANTS
PTEMP: BLOCK 1; PERMANENT TEMPS
TTEMP: BLOCK 1; TEMPORARY TEMPS
COMBAS: BLOCK 1; BASE OF COMMON
LLC: BLOCK 1; PROGRAM ORIGIN
BITP: BLOCK 1; BIT POINTER
BITC: BLOCK 1; BIT COUNT
PLTP: BLOCK 1; PROGRAMMER LABEL TABLE
MLTP: BLOCK 1; MADE LABEL TABLE
SDS: BLOCK 1 ;START OF DATA STATEMENTS
SDSTP: BLOCK 1 ;START OF DATA STATEMENTS POINTER
BLKSIZ: BLOCK 1; BLOCK SIZE
MODIF: BLOCK 1; ADDRESS MODIFICATION +1
SVFORH: BLOCK 1 ;SAVE H WHILE LOADING F4 PROGRAMS
IOWDPP: BLOCK 2>
SBRNAM: BLOCK 1
IFE K,<
CT1: BLOCK 1 ;TEMP FOR C
LTC: BLOCK 1
ITC: BLOCK 1
ENC: BLOCK 1
WCNT: BLOCK 1 ;DATA WORD COUNT
RCNT: BLOCK 1 ;DATA REPEAT COUNT
LTCTEM: BLOCK 1 ;TEMP FOR LTC
DWCT: BLOCK 1 ;DATA WORD COUNT>
VAR ;DUMP VARIABLES
IFN PURESW,<RELOC>
SUBTTL REMAP UUO
IFN REENT,<
IFN PURESW,<HHIGO: PHASE BUF1 ;DON'T NEED BUF1 NOW>
HIGO: CORE V, ;CORE UUO
JFCL ;NEVER FAILS
HINOGO: MOVE D,HVAL
CAMG D,HVAL1 ;ANYTHING IN HI-SEG
JRST 0 ;NO
IFN STANSW,<MOVE V,PRGCRD
TLZ V,777000 ;NO PROTECTION
CALLI V,400073 ;SET DATE & TIME WHICH WILL BE COPIED TO UPPER>
MOVE V,HISTRT ;NOW REMAP THE HISEG.
REMAP V, ;REMAP UUO.
JRST HIGET ;FATAL ERROR.
HIRET: JRST 0 ;EXECUTE CODE IN ACC'S
HIGET: HRRZI V,SEGBLK ;DATA FOR
GETSEG V, ;GETSEG UUO
SKIPA ;CANNOT CONTINUE NO HISEG
JRST REMPFL ;REGAINED LOADER HISEG
;GO PRINT MESSAGE
TTCALL 3,SEGMES ;PRINT SEGMES
EXIT ;AND DIE
SEGBLK: SIXBIT /SYS/
SIXBIT /LOADER/
EXP 0,0,0,0
SEGMES: ASCIZ /?CANNOT FIND LOADER.SHR
/
IFN PURESW,<HIGONE: DEPHASE>>
SUBTTL LISP LOADER
;END HERE IF 1K LOADER REQUESTED.
IFN K,<IFE L,<END BEG>
IFE L,< XLIST >
IFN L,< LIT
VAR
LODMAK: MOVEI A,LODMAK
MOVEM A,137
INIT 17
SIXBIT /DSK/
0
HALT
ENTER LMFILE
HALT
OUTPUT [IOWD 1,LMLST ;OUTPUT LENGTH OF FILE
0]
OUTPUT LMLST
STATZ 740000
HALT
RELEASE
CALL [SIXBIT /EXIT/]
LMFILE: SIXBIT /LISP/
SIXBIT /LOD/
0
0
LMLST: IOWD LODMAK+1-LD,137
0
END LODMAK>>
LIST
SUBTTL FORTRAN FOUR LOADER
F4LD: TLNE F,SKIPSW!FULLSW ;ARE WE IN SKIP MODE
JRST REJECT ;YES,DON'T LOAD ANY OF THIS
MOVEI W,-2(S); GENERATE TABLES
CAIG W,(H) ;NEED TO EXPAND?
IFN EXPAND,<PUSHJ P,[PUSHJ P,XPAND
TLOA F,FULLSW
JRST POPJM3
POPJ P,]>
IFE EXPAND,< TLO F,FULLSW>
;IFN REENT,<TRO F,F4FL!VFLG ;RE-ENTRANT LIB40>
TLO N,F4SW; SET FORTRAN FOUR FLAG
HRRZ V,R; SET PROG BREAK INTO V
MOVEM V,LLC; SAVE FIRST WORD ADDRESS
HRRZM W,MLTP; MADE LABELS
HRRZM W,PLTP; PROGRAMMER LABELS
ADD W,[POINT 1,1]; GENERATE BIT-BYTE POINTER
MOVEM W,BITP
MOVEM W,SDSTP; FIRST DATA STATEMENT
AOS SDSTP;
HRREI W,-↑D36; BITS PER WORDUM
MOVEM W,BITC; BIT COUNT
PUSHJ P,BITWX ;MAKE SURE OF ENOUGH SPACE
MOVE W,[JRST ALLOVE] ;LAST DATA STATEMENT
MOVEM W,(S)
TEXTR: PUSHJ P,WORD; TEXT BY DEFAULT
HLRZ C,W
CAIN C,-1
JRST HEADER; HEADER
MOVEI C,1; RELOCATABLE
TLNN F,FULLSW!SKIPSW ;DON'T LOAD IF EITHER SET
PUSHJ P,BITW; SHOVE AND STORE
JRST TEXTR; LOOP FOR NEXT WORD
ABS: SOSG BLKSIZ; MORE TO GET
JRST TEXTR; NOPE
ABSI: PUSHJ P,WORD;
MOVEI C,0; NON-RELOCATABLE
TLNN F,FULLSW!SKIPSW ;DON'T LOAD IF EITHER SET
PUSHJ P,BITW; TYPE 0
JRST ABS
SUBTTL PROCESS TABLE ENTRIES
MDLB: TLNE F,FULLSW+SKIPSW; MADE LABEL PROC
JRST GLOBDF; NO ROOM AT THE IN
HLRZ C,MLTP; GET PRESENT SIZE
CAMGE C,BLKSIZ; IF NEW SIZE BIGGER, STR-R-RETCH
PUSHJ P,SMLT
HRRZ C,MLTP; GET BASE
MLPLC: ADD C,BLKSIZ; MAKE INDEX
TLNN F,FULLSW+SKIPSW; DONT LOAD
HRRZM V,(C); PUT AWAY DEFINITION
GLOBDF: PUSHJ P,WORD
TLNE F,FULLSW+SKIPSW ;SKIPPING THIS PROG?
JRST TEXTR ;YES, DON'T DEFINE
MOVEI C,(V); AND LOC
EXCH W,C
PUSHJ P,SYMXX; PUT IN DDT-SYMBOL TABLE
PUSHJ P,BITWX
JRST TEXTR
PLB: TLNE F,FULLSW+SKIPSW
JRST GLOBDF
HLRZ C,PLTP; PRESENT SIZE
CAMGE C,BLKSIZ
PUSHJ P,SPLT
HRRZ C,PLTP
JRST MLPLC
SUBTTL STORE WORD AND SET BIT TABLE
BITW: MOVEM W,@X; STORE AWAY OFFSET
IDPB C,BITP; STORE BIT
AOSGE BITC; STEP BIT COUNT
AOJA V,BITWX; SOME MORE ROOM LEFT
HRREI C,-↑D36; RESET COUNT
MOVEM C,BITC
SOS PLTP
SOS BITP; ALL UPDATED
IFE EXPAND,<HRL C,MLTP
SOS MLTP
HRR C,MLTP>
IFN EXPAND,<HRRZ C,MLTP; TO ADDRESS
SUBI C,1
CAIG C,(H)
PUSHJ P,[PUSHJ P,XPAND
POPJ P,
ADDI C,2000
JRST POPJM2]
SOS MLTP
HRLI C,1(C)>
HRRZ T,SDSTP; GET DATA POINTER
BLT C,-1(T); MOVE DOWN LISTS
AOJ V,; STEP LOADER LOCATION
BITWX: IFN REENT,<
TLNE F,HIPROG
JRST FORTHI>
CAIGE H,@X
MOVEI H,@X ;KEEP H SET RIGHT FOR HISEG STUFF
BITWX2: HRRZ T,MLTP
CAIG T,(H); OVERFLOW CHECK
IFE EXPAND,<TLO F,FULLSW>
IFN EXPAND,<PUSHJ P, [PUSHJ P,XPAND
TLOA F,FULLSW
JRST POPJM3
POPJ P,]>
POPJ P,;
SMLT: SUB C,BLKSIZ; STRETCH
MOVS W,MLTP ;LEFT HALF HAS OLD BASE
ADD C,MLTP ;RIGHT HALF HAS NEW BASE
IFN EXPAND,< HRRZS C ;GET RID OF COUNT
CAIG C,(H)
PUSHJ P,[PUSHJ P,XPAND
POPJ P,
ADD W,[XWD 2000,0]
ADDI C,2000
JRST POPJM2]>
HRRM C,MLTP ;PUT IN NEW MLTP
HLL C,W ;FORM BLT POINTER
ADDI W,(C) ;LAST ENTRY OF MLTP
HRL W,BLKSIZ ;NEW SIZE OF MLTP
HLLM W,MLTP ;...
SLTC: BLT C,0(W); MOVE DOWN (UP?)
POPJ P,;
SPLT: SUB C,BLKSIZ
MOVS W,MLTP;
ADDM C,PLTP
ADD C,MLTP
IFN EXPAND,< HRRZS C
CAIG C,(H)
PUSHJ P,[PUSHJ P,XPAND
POPJ P,
ADD W,[XWD 2000,0]
ADDI C,2000
JRST POPJM2]>
HRRM C,MLTP ;PUT IN NEW MLTP
HLL C,W
HLRZ W,PLTP ;OLD SIZE OF PL TABLE
ADD W,PLTP ;NEW BASE OF PL TABLE
HRL W,BLKSIZ ;NEW SIZE OF PL TABLE
HLLM W,PLTP ;INTO POINTER
JRST SLTC
IFN REENT,<
FORTHI: HRRZ T,JOBREL ;CHECK FOR CORE OVERFLOW
CAIGE T,@X
PUSHJ P,[PUSHJ P,HIEXP
TLOA F,FULLSW
JRST POPJM3 ;CHECK AGAIN
POPJ P,]
JRST BITWX2>
SUBTTL PROCESS END CODE WORD
ENDS: PUSHJ P,WORD; GET STARTING ADDRESS
JUMPE W,ENDS1; NOT MAIN
ADDI W,(R); RELOCATION OFFSET
TLNE N,ISAFLG; IGNORE STARTING ADDRESS
JRST ENDS1
HRRZM W,STADDR ;STORE STARTING ADDRESS
IFN STANSW&REENT,<MOVE W,DTIN+2
MOVEM W,PRGCRD ;DATE & TIME FOR SETCRD>
IFN NAMESW,<MOVE W,1(N) ;SET UP NAME
PUSHJ P,LDNAM
MOVE W,DTIN
MOVEM W,PRGNAM>
ENDS1: PUSHJ P,WORDPR ;DATA STORE SIZE
HRRZM C,PTEMP ;NUMBER OF PERMANENT TEMPS
MOVEM V,CCON; START OF CONSTANTS AREA
JUMPE W,E1; NULL
MOVEM W,BLKSIZ ;SAVE COUNT
MOVEI W,0(V) ;DEFINE CONST.
MOVE C,CNR50 ;...
TLNN F,SKIPSW!FULLSW
PUSHJ P,SYMPT ;...
PUSHJ P,GSWD ;STORE CONSTANT TABLE
E1: MOVEI W,0(V); GET LOADER LOC
EXCH W,PTEMP; STORE INTO PERM TEMP POINTER
ADD W,PTEMP; FORM TEMP TEMP ADDRESS
MOVEM W,TTEMP; POINTER
MOVEM V,GSTAB; STORE LOADER LOC IN GLOBSUB
MOVEM H,SVFORH
MOVE C,TTR50 ;DEFINE %TEMP.
TLNE F,SKIPSW!FULLSW
JRST E1A
PUSHJ P,SYMPT ;...
MOVE C,PTR50 ;DEFINE (IF EXTANT) TEMP.
MOVEI W,0(V) ;...
CAME W,TTEMP ;ANY PERM TEMPS?
PUSHJ P,SYMPT ;YES, DEFINE
E1A: PUSHJ P,WORD; NUMBER OF GLOBSUBS
JUMPE W,E11
MOVEM W,BLKSIZ ;SIZE OF GLOBSUB
PUSHJ P,GSWD ;STORE GLOBSUB TABLE
E11: MOVEM V,STAB; SCALARS
PUSHJ P,WORD; HOW MANY?
JUMPE W,E21; NONE
PUSHJ P,GSWDPR ;STORE SCALAR TABLE
E21: MOVEM V,ATAB; ARRAY POINTER
PUSHJ P,WORD; COMMENTS FOR SCALARS APPLY
JUMPE W,E31
PUSHJ P,GSWDPR ;STORE ARRAY TABLE
E31: MOVEM V,AOTAB; ARRAYS OFFSET
PUSHJ P,WORD; SAME COMMENTS AS ABOVE
JUMPE W,E41
PUSHJ P,GSWDPR ;STORE ARRAY OFFSET TABLE
E41: PUSHJ P,WORD; TEMP, SCALAR, ARRAY SIZE
TLNE F,FULLSW!SKIPSW ;SKIPPING THIS PROG?
MOVEI W,0 ;DON'T ACCEPT GLOB SUBPROG REQUESTS
MOVEM V,CTAB; SETUP COMMON TABLE POINTER
ADD W,GSTAB; GLOBAL SUBPROG BASE
MOVEM W,COMBAS; START OF COMMON
PUSHJ P,WORD; COMMON BLOCK SIZE
HRRZM W,BLKSIZ
JUMPE W,PASS2; NO COMMON
COMTOP: PUSHJ P,WORDPR ;GET A COMMON PAIR
TLNE F,SKIPSW!FULLSW ;IF SKIPPING
JRST COMCO1 ;DON'T USE
PUSHJ P,SDEF; SEARCH
JRST COMYES; ALREADY THERE
HRLS W
HRR W,COMBAS; PICK UP THIS COMMON LOC
TLNN F,SKIPSW!FULLSW
PUSHJ P,SYMXX; DEFINE IT
MOVS W,W; SWAP HALFS
ADD W,COMBAS; UPDATE COMMON LOC
HRRM W,COMBAS; OLD BASE PLUS NEW SIZE
HLRZS W; RETURN ADDRESS
TLZ C,400000
TLNN F,SKIPSW!FULLSW
PUSHJ P,SYMXX
COMCOM: PUSHJ P,CWSTWX ;STORE A WORD PAIR
COMCO1: SOS BLKSIZ
SOSLE BLKSIZ
JRST COMTOP
JRST PASS2
COMYES: HLRZ C,2(A); PICK UP DEFINITION
CAMLE W,C; CHECK SIZE
JRST ILC; ILLEGAL COMMON
MOVE C,1(A); NAME
HRRZ W,2(A); BASE
JRST COMCOM
PRSTWX: PUSHJ P,WORDPR ;GET A WORD PAIR
CWSTWX: EXCH C,W ;SPACE TO STORE FIRST WORD OF PAIR?
PUSHJ P,WSTWX ;...
EXCH C,W ;THERE WAS; IT'S STORED
WSTWX: TLNE F,FULLSW!SKIPSW ;SPACE FOR ANOTHER WORD?
POPJ P, ;NOPE, RETURN
MOVEM W,@X ;YES, STORE IT.
AOJA V,BITWX ;TELL THE TABLES ABOUT IT; THEN RETURN
GSWD: PUSHJ P,WORD ;GET WORD FROM TABLE
PUSHJ P,WSTWX ;STASH IT
SOSE BLKSIZ ;FINISHED?
JRST GSWD ;NOPE, LOOP
POPJ P, ;TRA 1,4
GSWDPR: MOVEM W,BLKSIZ ;KEEP COUNT
GSWDP1: PUSHJ P,PRSTWX ;GET AND STASH A PAIR
SOS BLKSIZ ;FINISHED?
SOSLE BLKSIZ ;...
JRST GSWDP1 ;NOPE, LOOP
POPJ P, ;TRA 1,4
SUBTTL BEGIN HERE PASS2 TEXT PROCESSING
PASS2: ADDI V,(X)
IFN REENT,<TLNE F,HIPROG
HRRZ V,H>
MOVEM V,TOPTAB ;SAVE FOR OVERLAP CHECKING
TLNE F,FULLSW+SKIPSW; ABORT?
JRST ALLOVE; YES
MOVE V,LLC ;PICK UP PROGRAM ORIGIN
CAML V,CCON ;IS THIS A PROGRAM?
JRST FBLKD ;NO, GO LOOK FOR FIRST BLK DATA
TLOE N,PGM1 ;YES, IS THIS FIRST F4 PROG?
JRST NOPRG ;NO
HRR W,COMBAS ;YES, PLACE PROG BREAK IN LH
IFE L,<IFN REENT,<TLNN F,HIPROG ;DON'T BOTHER IF IN HISEG, CHAIN NOT SMART ENOUGH>
HRLM W,JOBCHN(X) ;FOR CHAIN>
NOPRG: HRRZ W,PLTP; GET PROG TABLE BASE
HLRZ C,PLTP; AND SIZE
ADD W,C; COMPUTE END OF PROG TABLE
ADD W,[POINT 1,1]; AND BEGINNING OF BIT TABLE
EXCH W,BITP; SWAP POINTERS
PASS2B: ILDB C,BITP; GET A BIT
JUMPE C,PASS2C; NO PASS2 PROCESSING
PUSHJ P,PROC; PROCESS A TAG
JRST PASS2B; MORE TO COME
JRST ENDTP;
PROC: LDB C,[POINT 6,@X,23]; TAG
SETZM MODIF; ZERO TO ADDRESS MODIFIER
TRZE C,40
AOS MODIF
MOVEI W,TABDIS; HEAD OF TABLE
HRLI W,-TABLNG ;SET UP FOR AOBJN
HLRZ T,(W); GET ENTRY
CAME T,C; CHECK
AOBJN W,.-2
JUMPGE W,LOAD4A ;RAN OUT OF ENTRIES
HRRZ W,(W); GET DISPATCH
LDB C,[POINT 12,@X,35]
JRST (W); DISPATCH
PASS2C: PUSHJ P,PASS2A
JRST PASS2B
JRST ENDTP
TABDIS: XWD 11,PCONS; CONSTANTS
XWD 06,PGS; GLOBAL SUBPROGRAMS
XWD 20,PST; SCALARS
XWD 22,PAT; ARRAYS
XWD 01,PATO; ARRAYS OFFSET
XWD 00,PPLT; PROGRAMMER LABELS
XWD 31,PMLT; MADE LABESL
XWD 26,PPT; PERMANENT TEMPORARYS
XWD 27,PTT; TEMPORARY TEMPORARYS
TABLNG==.-TABDIS
;DISPATCH ON A HEADER
HEADER: CAMN W,[EXP -2]; END OF PASS ONE
JRST ENDS
LDB C,[POINT 12,W,35]; GET SIZE
MOVEM C,BLKSIZ
ANDI W,770000
JUMPE W,PLB; PROGRAMMER LABEL
CAIN W,500000; ABSOLUTE BLOCK
JRST ABSI;
CAIN W,310000; MADE LABEL
JRST MDLB; MADE LABEL
CAIN W,600000
JRST GLOBDF
CAIN W,700000; DATA STATEMENT
JRST DATAS
JRST LOAD4A; DATA STATEMENTS WILL GO HERE
TTR50: RADIX50 10,%TEMP.
PTR50: RADIX50 10,TEMP.
CNR50: RADIX50 10,CONST.
SUBTTL ROUTINES TO PROCESS POINTERS
PCONS: ADD C,CCON; GENERATE CONSTANT ADDRESS
SOJA C,PCOMX ;ADJUST FOR 1 AS FIRST ENTRY
PSTA: PUSHJ P,SWAPSY ;NON-COMMON SCALARS AND ARRAYS
ADDI C,(R); RELOCATE
PCOM1: PUSHJ P,SYDEF ;...
PCOMX: ADD C,MODIF ;ADDR RELOC FOR DP
HRRM C,@X; REPLACE ADDRESS
PASS2A: AOJ V,; STEP READOUT POINTER
CAML V,CCON ;END OF PROCESSABLES?
CPOPJ1: AOS (P); SKIP
POPJ P,;
PAT: SKIPA W,ATAB ;ARRAY TABLE BASE
PST: MOVE W,STAB ;SCALAR TABLE BASE
ROT C,1 ;SCALE BY 2
ADD C,W ;ADD IN TABLE BASE
ADDI C,-2(X); TABLE ENTRY
HLRZ W,(C); CHECK FOR COMMON
JUMPE W,PSTA; NO COMMON
PUSHJ P,COMDID ;PROCESS COMMON
JRST PCOM1
COMDID: LSH W,1 ;PROCESS COMMON TABLE ENTRIES
ADD W,CTAB; COMMON TAG
ADDI W,-2(X); OFFSET
PUSHJ P,SWAPSY; GET SYMBOL AND SET TO DEFINED
ADD C,1(W); BASE OF COMMON
POPJ P, ;RETURN
PATO: ROT C,1
ADD C,AOTAB; ARRAY OFFSET
ADDI C,-2(X); LOADER OFFSET
MOVEM C,CT1; SAVE CURRENT POINTER
HRRZ C,1(C); PICK UP REFERENCE POINTER
ANDI C,7777; MASK TO ADDRESS
ROT C,1; ALWAYS A ARRAY
ADDI C,-2(X)
ADD C,ATAB
HLRZ W,(C); COMMON CHECK
JUMPE W,NCO
PUSHJ P,COMDID ;PROCESS COMMON
PUSHJ P,SYDEF
MOVE C,CT1
HRRE C,(C)
ADD C,1(W)
JRST PCOMX
NCO: PUSHJ P,SWAPSY;
ADDI C,(R) ;DEFINE SYMBOL IN TRUE LOC
PUSHJ P,SYDEF ;...
MOVE C,CT1
HRRZ C,(C) ;OFFSET ADDRESS PICKUP
ADDI C,(R) ;WHERE IT WILL BE
JRST PCOMX ;STASH ADDR AWAY
PTT: ADD C,TTEMP; TEMPORARY TEMPS
SOJA C,PCOMX ;ADJUST FOR 1 AS FIRST ENTRY
PPT: ADD C,PTEMP; PERMANENT TEMPS
SOJA C,PCOMX ;ADJUST FOR 1 AS FIRST ENTRY
PGS: ADD C,GSTAB; GLOBSUBS
ADDI C,-1(X); OFFSET
MOVE C,(C)
TLC C,640000; MAKE A REQUEST
PUSHJ P,TBLCHK ;CHECK FOR OVERLAP
MOVEI W,(V); THIS LOC
HLRM W,@X; ZERO RIGHT HALF
PUSHJ P,SYMXX
JRST PASS2A
SYDEF: TLNE N,SYDAT ;SYMBOL WANTS DEFININITION?
POPJ P, ;NO, GO AWAY
PUSH P,C ;SAVE THE WORLD
PUSH P,W
PUSHJ P,TBLCHK ;CHECK FOR OVERLAP
MOVE W,C
SKIPE C,T ;PICKUP VALUE
PUSHJ P,SYMXX
POP P,W
POP P,C
POPJ P,;
PMLT: ADD C,MLTP
JRST .+2
PPLT: ADD C,PLTP
HRRZ C,(C)
JRST PCOMX
SYMXX: PUSH P,V
PUSHJ P,SYMPT
POP P,V
IFE REENT,<POPJ P,>
IFN REENT,<JRST RESTRX>
SWAPSY: MOVEI T,0; SET TO EXCHANGE DEFS
EXCH T,1(C); GET NAME
HRRZ C,(C) ;GET VALUE
POPJ P,
TBLCHK: HRRZ W,MLTP ;GETT TOP OV TABLES
SUBI W,2
CAMG W,TOPTAB ;WILL IT OVERLAP
IFE EXPAND,<TLO F,FULLSW>
IFN EXPAND,<JRST [PUSHJ P,XPAND
TLOA F,FULLSW
JRST TBLCHK
POPJ P,]>
POPJ P,
SUBTTL END OF PASS2
ALLOVE: TLZ N,F4SW ;END OF F4 PROG
HRRZ V,SDSTP ;GET READY TO ZERO OUT DATA STMTS
SETZM (V) ;AT LEAST ONE THERE
CAIL V,(S) ;IS THERE MORE THAN ONE??
JRST NOMODS ;NO
HRLS V
ADDI V,1 ;SET UP BLT
BLT V,(S) ;ZERO OUT ALL OF IT
NOMODS: MOVE H,SVFORH
TLNE F,FULLSW!SKIPSW
JRST HIGH3A
HRR R,COMBAS ;TOP OF THE DATA
CAMG H,SDS ;HIGHEST LOC GREATER THAN DATA STATEMENTS?
JRST HIGH3A ;NO, RETURN
ADDI H,1(S) ;YES, SET UP MEANINGFUL ERROR COMMENT
SUB H,SDS ;...
TLO F,FULLSW ;INDICATE OVERFLO
HIGH3A: IFN REENT,<SETZ W, ;CAUSES TROUBLE OTHERWISE
TLZE F,HIPROG
JRST HIGHN1
HRRZ V,GSTAB
MOVEI V,@X
CAMLE V,HILOW
MOVEM V,HILOW>
HRRZ C,R
JRST HIGH31 ;RETURN
DATAS: TLNE F,FULLSW+SKIPSW
JRST DAX
MOVEI C,(S) ;ADDR OF WORD UNDER SYMBOL TABLE
MOVN W,BLKSIZ ;HOW FAR DOWN TO BLT
ADDM W,PLTP ;UPDATE TABLE POINTERS
ADDM W,BITP ;...
ADDM W,SDSTP ;...
ADD C,W ;RH(C):= WHEN TO STOP BLT
HRL C,MLTP ;SOURCE OF BLTED DATA
ADD W,MLTP ;UPDATE, GET DESTINATION OF BLT DATA
IFN EXPAND,< HRRZS W ;GET RID OF LEFT HALF
CAIG W,(H)
PUSHJ P,[PUSHJ P,XPAND
POPJ P,
ADDI W,2000
ADD C,[XWD 2000,2000]
JRST POPJM2]>
HRRM W,MLTP ;NO SET THIS SO EXTRA CORE NOT ZEROED
HLL W,C ;FORM BLT POINTER
BLT W,-1(C) ;MOVE TABLES DOWN (BUT NOT JRST ALLOVE)
PUSHJ P,BITWX
DAX: PUSHJ P,WORD; READ ONE WORD
TLNN F,FULLSW+SKIPSW
MOVEM W,(C)
SOSLE BLKSIZ ;COUNT OF DATA SEQUENCE SIZE
AOJA C,DAX ;INCREMENT DATA SEQUENCE DEPOSIT LOC
JRST TEXTR; DONE
FBLKD: TLOE N,BLKD1 ;IS THIS FIRST BLOCK DATA?
JRST ENDTP ;NO
HRR V,COMBAS ;PLACE PROG BREAK IN RH FOR
IFE L,<IFN REENT,< TLNN F,HIPROG>
HRRM V,JOBCHN(X) ;CHAIN>
ENDTP: TLNE F,FULLSW+SKIPSW
JRST ALLOVE
HRR V,GSTAB
ENDTP0: CAML V,STAB; ANY MORE GLOBSUBS
JRST ENDTP2; NO
MOVE C,@X; GET SUBPROG NAME
PUSHJ P,SREQ; IS IT ALLREADY REQUESTED
AOJA V,ENDTP0; YES
PUSHJ P,SDEF; OR DEFINED
AOJA V,ENDTP0; YES
PUSHJ P,TBLCHK
MOVEI W,0 ;PREPARE DUMMY LINK
TLNN F,FULLSW+SKIPSW ;ABORT
PUSHJ P,SYM3X; PUT IN DUMMY REQUEST
PUSHJ P,BITWX; OVERLAP CHECK
AOJA V,ENDTP0
ENDTP2: SETZM PT1
ENDTPW: HRRZ V,SDSTP
IFN EXPAND,<IFN REENT,<TLNE F,HIPROG
JRST ENDTPI>
SUBI V,(X)
CAMG V,COMBAS
JRST [SUB V,COMBAS
MOVNS V
PUSHJ P,XPAND9
TLO F,FULLSW
JRST .+1]
ENDTPH: HRR V,SDSTP>
HRRZM V,SDS ;DATA STATEMENT LOC
ENDTP1: SUBI V,(X); COMPENSATE FOR OFFSET
MOVE W,@X; GET WORD
TLNE W,-1; NO LEFT HALF IMPLIES COUNT
JRST DODON; DATA DONE
ADD W,[MOVEI W,3]
ADDI W,@X
EXCH W,@X
AOJ V,
ADD W,@X; ITEMS COUNT
MOVEM W,ITC
MOVE W,[MOVEM W,LTC]
MOVEM W,@X; SETUP FOR DATA EXECUTION
AOJ V,
MOVSI W,(MOVEI W,0)
EXCH W,@X
MOVEM W,ENC; END COUNT
AOJ V,
MOVEI W,@X
ADDM W,ITC
LOOP: MOVE W,@X
HLRZ T,W; LEFT HALF INST.
ANDI T,777000
CAIN T,254000 ;JRST?
JRST WRAP ;END OF DATA
CAIN T,260000 ;PUSHJ?
JRST PJTABL(W) ;DISPATCH VIA TABLE
CAIN T,200000; MOVE?
AOJA V,INNER
CAIN T,270000; ADD?
JRST ADDOP
CAIN T,221000; IMULI?
AOJA V,LOOP
CAIE T,220000; IMUL?
JRST LOAD4A; NOTA
INNER: HRRZ T,@X; GET ADDRESS
TRZE T,770000; ZERO TAG?
SOJA T,CONPOL; NO, CONSTANT POOL
JUMPE T,FORCNF
SUB T,PT1; SUBTRACT INDUCTION NUMBER
ASH T,1
SUBI T,1
HRRM T,@X
HLRZ T,@X
ADDI T,P
HRLM T,@X
AOJA V,LOOP
IFN EXPAND,<IFN REENT,<ENDTPI: HRRZ V,COMBAS
MOVEI V,@X
CAMLE V,JOBREL
JRST [PUSHJ P,HIEXP
TLOA F,FULLSW
JRST ENDTPI
JRST ENDTPH]
JRST ENDTPH>>
FORCNF: ERROR ,</FORTRAN CONFUSED ABOUT DATA STATEMENTS#/>
JRST LD2
CONPOL: ADD T,ITC; CONSTANT BASE
HRRM T,@X
AOJA V,LOOP
ADDOP: HRRZ T,@X
TRZE T,770000
SOJA T,CONPOL
SKIPIN: AOJA V,LOOP
PJTABL: JRST DWFS ;PUSHJ 17,0
AOSA PT1 ;INCREMENT DO COUNT
SOSA PT1; DECREMENT DO COUNT
SKIPA W,[EXP DOINT.]
MOVEI W,DOEND.
HRRM W,@X
AOJA V,SKIPIN ;SKIP A WORD
DWFS: MOVEI W,DWFS.
HRRM W,@X
AOJ V,
TLO N,SYDAT
PUSHJ P,PROC; PROCESS THE TAG
JRST LOAD4A ;DATA STATEMENT BELOW CODE TOP
JRST LOOP ;PROPER RETURN
DOINT.: POP P,V; GET ADDRESS OF INITIAL VALUE
PUSH P,(V); STORE INDUCTION VARIABLE
AOJ V,
PUSH P,V; INITIAL ADDRESS
JRST (V)
DOEND.: HLRE T,@(P) ;RETAIN SIGN OF INCREMENT
ADDM T,-2(P); INCREMENT
HRRZ T,@(P); GET FINAL VALUE
SUB T,-2(P) ;FINAL - CURRENT
IMUL T,@(P) ;INCLUDE SIGN OF INCREMENT
JUMPL T,DODONE ;SIGN IS ONLY IMPORTANT THING
POP P,(P); BACK UP POINTER
JRST @(P)
DODONE: POP P,-1(P); BACK UP ADDRESS
POP P,-1(P)
JRST CPOPJ1 ;RETURN
WRAP: MOVE W,ENC; NUMBER OF CONSTANTS
ADD W,ITC; CONSTANT BASE
MOVEI C,(W); CHAIN
HRRM C,@X
MOVEI V,(W); READY TO GO
JRST ENDTP1
DODON: TLZ N,RCF!SYDAT!DZER ;DATA STATEMENT FLAGS
MOVE W,PTEMP ;TOP OF PROG
ADDI W,(X) ;+OFFSET
HRRZ C,SDS
IFE EXPAND,<SUBI C,(X) ;CHECK FOR ROOM
CAMGE C,COMBAS ;IS IT THERE
TLO F,FULLSW ;NO (DONE EARLIER IF EXPAND)
HRRZ C,SDS>
SUBI C,1 ;GET ONE LESS (TOP LOCATION TO ZERO)
IFN REENT,<TLNE F,HIPROG
MOVE C,JOBREL>
SECZER: CAMLE W,C ;ANY DATA TO ZERO?
JRST @SDS ;NO, DO DATA STATEMENTS
;FULLSW IS ON IF COMBAS GT. SDS
TLNN F,FULLSW+SKIPSW ;SHOULD WE ZERO?
SETZM (W) ;YES, DO SO
TLON N,DZER ;GO BACK FOR MORE?
AOJA W,SECZER ;YES, PLEASE
HRLI W,-1(W) ;SET UP BLT POINTER TO ZERO DATA
TLNN F,FULLSW+SKIPSW ;SHOULD WE ZERO?
BLT W,(C) ;YES, DO SO
JRST @SDS ;GO DO DATA STATEMENTS
DATAOV: ERROR 0,</DATA STATEMENT OVERFLOW#/>
JRST LD2
DREAD: TLNE N,RCF; NEW REPEAT COUNT NEEDED
JRST FETCH; NO
MOVE W,LTC
MOVEM W,LTCTEM
MOVE W,@LTC; GET A WORD
HLRZM W,RCNT; SET REPEAT COUNT
HRRZM W,WCNT; SET WORD COUNT
POP W,(W); SUBTRACT ONE FROM BOTH HALFS
HLLM W,@LTC; DECREMENT REPEAT COUNT
AOS W,LTC; STEP READOUT
TLO N,RCF
FETCH: MOVE W,@LTC
AOS LTC
SOSE WCNT
POPJ P,;
SOSN RCNT
JRST DOFF.
MOVE V,LTCTEM; RESTORE READOUT
MOVEM V,LTC
DOFF.: TLZ N,RCF; RESET DATA REPEAT FLAG
POPJ P,;
DWFS.: MOVE T,(P)
AOS (P)
MOVE T,(T); GET ADDRESS
HLRZM T,DWCT; DATA WORD COUNT
HRRZS T
ADDI T,(W); OFFSET
IFN REENT,<HRRZS T ;CLEAR LEFT HALF INCASE OF CARRY
CAML T,HVAL1
JRST [ADD T,HIGHX
HRRZS T ;MUST GET RID OF LEFT HALF
CAMLE T,JOBREL
JRST DATAOV ;IN CASE FORTRAN GOOFS ON LIMITS
JRST DWFS.1]
ADD T,LOWX
HRRZS T>
IFE REENT,<ADDI T,(X)>
CAML T,SDS
JRST DATAOV
DWFS.1: PUSHJ P,DREAD ;GET A DATA WORD
HRRZS T
IFN REENT,<CAMG T,JOBREL ;JUST TO MAKE SURE>
CAMN T,SDS
JRST DATAOV
TLNN F,FULLSW+SKIPSW ;LOAD THE NEXT DATA ITEM?
MOVEM W,(T) ;YES, STORE IT
SOSE W,DWCT; STEP DOWN AND TEST
AOJA T,DWFS.1 ;ONE MORE TIME, MOZART BABY!
POPJ P,
SUBTTL ROUTINE TO SKIP FORTRAN OUTPUT
;SUBSECTION OF THE ROUTINE TO HANDLE OUTPUT FROM THE
;FORTRAN IV COMPILER. THE MAIN OBJECT OF THE ROUTINE IS TO
;LOOK FOR THE END BLOCK. CODE TAKEN FROM FUDGE2.
MACHCD: HRRZ C,W ;GET THE WORD COUNT
PUSHJ P,WORD ;INPUT A WORD
SOJG C,MACHCD ;LOOP BACK FOR REST OF THE BLOCK
;GO LOOK FOR NEXT BLOCK
REJECT: PUSHJ P,WORD ;READ A FORTRAN BLOCK HEADER
TLC W,-1 ;TURN ONES TO ZEROES IN LEFT HALF
TLNE W,-1 ;WAS LEFT HALF ALL ONES?
JRST REJECT ;NO, IT WAS CALCULATED MACHINE CODE
CAIN W,-2 ;YES, IS RIGHT HALF = 777776?
JRST ENDST ;YES, PROCESS F4 END BLOCK
LDB C,[POINT 6,W,23];GET CODE BITS FROM BITS 18-23
TRZ W,770000 ;THEN WIPE THEM OUT
CAIE C,70 ;IS IT A DATA STATEMENT?
CAIN C,50 ;IS IT ABSOLUTE MACHINE CODE?
JRST MACHCD ;YES, TREAT IT LIKE DATA STATEMENTS
PUSHJ P,WORD ;NO, ITS A LABEL OF SOME SORT
JRST REJECT ;WHICH CONSISTS OF ONE WORD
;LOOK FOR NEXT BLOCK HEADER
ENDST: MOVEI C,1 ;TWO WORDS, FIVE TABLES, ONE WORD, ONE TABLE
MOVEI T,6 ;TO GO
F4LUP1: PUSHJ P,WORD ;GET TABLE MEMBER
F4LUP3: SOJGE C,F4LUP1 ;LOOP WITHIN A TABLE
JUMPL T,LOAD1 ;LAST TABLE - RETURN
SOJG T,F4LUP2 ;FIRST TWO WORDS AND FIVE TABLES
JUMPE T,F4LUP1 ;COMMON LENGTH WORD
F4LUP2: PUSHJ P,WORD ;READ HEADER WORD
MOVE C,W ;COUNT TO COUNTER
JRST F4LUP3 ;STASH
SUBTTL LISP LOADER
IFE L,< END BEG>
IFN L,<
LIT
VAR
LODMAK: MOVEI A,LODMAK
MOVEM A,137
INIT 17
SIXBIT /DSK/
0
HALT
ENTER LMFILE
HALT
OUTPUT [IOWD 1,LMLST ;OUTPUT LENGTH OF FILE
0]
OUTPUT LMLST
STATZ 740000
HALT
RELEASE
CALL [SIXBIT /EXIT/]
LMFILE: SIXBIT /LISP/
SIXBIT /LOD/
0
0
LMLST: IOWD LODMAK+1-LD,137
0
END LODMAK>